OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
fvmesh.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!|| fvmesh1 ../engine/source/airbag/fvmesh.F
25!||--- called by ------------------------------------------------------
26!|| fvmesh0 ../engine/source/airbag/fvmesh0.F
27!||--- calls -----------------------------------------------------
28!|| arret ../engine/source/system/arret.F
29!|| c_tricall ../engine/stub/fvmbags_stub.F
30!|| coorloc ../engine/source/airbag/fvmesh.F
31!|| facepoly ../engine/source/airbag/fvmesh.F
32!|| gpolcut ../engine/source/airbag/fvmesh.F
33!|| horiedge ../engine/source/airbag/fvmesh.F
34!|| horipoly ../engine/source/airbag/fvmesh.F
35!|| itribox ../engine/source/airbag/fvmesh.F
36!|| polyhedr ../engine/source/airbag/fvmesh.F
37!|| progbar_c ../common_source/sortie/progbar_c.c
38!|| spmd_fvb_gath ../engine/source/mpi/airbags/spmd_fvb_gath.F
39!|| tribox3 ../engine/stub/fvmbags_stub.F
40!|| tritri3 ../engine/stub/fvmbags_stub.F
41!||--- uses -----------------------------------------------------
42!|| fvbag_mod ../engine/share/modules/fvbag_mod.F
43!||====================================================================
44 SUBROUTINE fvmesh1(IBUF , ELEM , X , IVOLU, BRIC ,
45 . XB , RVOLU , NEL , NBRIC, TBRIC,
46 . SFAC , DXM , NBA , NELA , NNA ,
47 . TBA , TFACA , TAGELS, IBUFA,
48 . ELEMA, TAGELA, IXS , NNF )
49C-----------------------------------------------
50C M o d u l e s
51C-----------------------------------------------
52 USE fvbag_mod
53C-----------------------------------------------
54C I m p l i c i t T y p e s
55C-----------------------------------------------
56#include "implicit_f.inc"
57C-----------------------------------------------
58C C o m m o n B l o c k s
59C-----------------------------------------------
60#include "com01_c.inc"
61#include "units_c.inc"
62#include "sysunit.inc"
63#include "task_c.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 INTEGER IBUF(*), ELEM(3,*), IVOLU(*), BRIC(8,*),
68 . NEL, NBRIC, TBRIC(13,*), NBA, NELA, NNA, TBA(2,*),
69 . TFACA(12,*), TAGELS(*), IBUFA(*), ELEMA(3,*), TAGELA(*),
70 . IXS(NIXS,*), NNF
71 my_real
72 . x(3,*), xb(3,*), rvolu(*), sfac(6,4,*), dxm
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER ILVOUT, NLAYER, NFACMAX, NPPMAX, I, J, IEL, N1, N2, N3,
77 . NN1, NN2, NN3, GRBRIC, IAD, NPOLY, NNS, ITAGB(NBRIC),
78 . NVMAX, NG, INFO, ICUT, NVERTS, NF1, NF2, NF3, NF4, NS,
79 . NSMAX, NV, K, KK, NNP, NPOLMAX, NRPMAX, N, M, MM, NPOLH,
80 . npolb, ity, nn, nphmax, npolhmax, jj, jjj, ii,
81 . nns_old, nnp_old, npa, jmax, imax, jjmax, np, nntr,
82 . npoly_old, ipsurf, ic1, ic2, nhol, nelp, npolh_old,
83 . l, ll, ifv, nns2, npoly2, npl, polc, nspoly, ncpoly,
84 . npolhf, nnb, filen, lenp, lenh, ip, jmin, lenimax,
85 . lenrmax, kkk, nseg, imin, nfac, n4, nn4, ib, ifound,
86 . itagba(nba), ibsa(nba), nall, iii,
87 . nns_anim, nbz, nbnedge, nns3, npoly_new, nnsp, nedge,
88 . ityz, inz, j0, nns1, k0, i1, i2, idep, nstr, nctr, iiz,
89 . nnsa
90 parameter(nvmax=12)
91 my_real
92 . volg, x1, y1, z1, x2, y2, z2, x3, y3, z3, x12, y12, z12,
93 . x13, y13, z13, nrx, nry, nrz, area2, elarea(nel),
94 . norm(3,nel), xbmax, ybmax, zbmax, xbmin, ybmin, zbmin,
95 . xc, yc, zc, xx, yy, zz, pp(3,3), xl7(3), bcenter(3),
96 . bhalfsize(3), xtmax, ytmax, ztmax, xtmin, ytmin, ztmin,
97 . tverts(9), tmptri(3,3), tmpbox(3,8), tmpnorm(3,6), tole,
98 . xg, yg, zg, fv0(3), fv1(3), fv2(3), fu0(3), fu1(3),
99 . fu2(3), quad(3,4), nr(3), area, nx, ny, nz, nnx,
100 . nny, nnz, x0, y0, z0, lmax2, tole2, dd, vm, volumin,
101 . areamax, volph, areap, areael, vpx, vpy, vpz,
102 . v1x, v1y, v1z, v2x, v2y, v2z, nrm1, vx, vy, vz, ss,
103 . normf(3,4), ksi, eta, vx1, vy1, vz1, vx2, vy2, vz2,
104 . vmin, vtmp, x4, y4, z4, x14, y14, z14, norma(3,nela),
105 . dd2, xn(3), zlmin, zlmax, zl, vnorm, vx3, vy3, vz3, lz,
106 . dz, alpha, gamai, cpai, cpbi, cpci, rmwi, pini, ti, cpi,
107 . cvi, rhoi, zl1, zl2, zl3, zlc, val, xxx(3,nnf),
108 . xxxa(3,nna)
109 CHARACTER CHFVB*7, CHMESH*5, FILNAM*116
110C
111 INTEGER, ALLOCATABLE :: FACET(:,:), IPOLY(:,:),
112 . IELNOD(:,:), POLH(:,:), IPOLY_F(:,:),
113 . polh_f(:,:), ifvnod(:), ifvnod_old(:),
114 . redir_poly(:), pseg(:,:), redir(:),
115 . ptri(:,:), redir_polh(:), polb(:),
116 . ipoly_old(:), polh_new(:,:), itagt(:),
117 . tri(:,:), adr(:), adr_old(:), imerged(:),
118 . ipoly_f_old(:,:), inedge(:,:), nref(:,:),
119 . iz(:,:), ledge(:), ifvnod2(:,:), itagn(:)
120 my_real
121 . , ALLOCATABLE :: normt(:,:), poly(:,:), rpoly(:,:),
122 . rpoly_f(:,:), volu(:), pnodes(:,:),
123 . pholes(:,:), rpoly_old(:), volusort(:),
124 . volu_old(:), rpoly_f_old(:,:),
125 . rfvnod_old(:,:), xnew(:,:), rnedge(:,:),
126 . aref(:,:), rfvnod2(:,:), xns(:,:),
127 . xns2(:,:), xxxsa(:,:)
128C
129 INTEGER FAC(4,6), FACNOR(4,6), FAC4(3,4)
130 DATA FAC /1,4,3,2,
131 . 5,6,7,8,
132 . 1,2,6,5,
133 . 2,3,7,6,
134 . 3,4,8,7,
135 . 4,1,5,8/
136 DATA facnor /3,4,5,6,
137 . 3,4,5,6,
138 . 1,4,2,6,
139 . 1,5,2,3,
140 . 1,6,2,4,
141 . 1,3,2,5/
142 DATA fac4 /1,5,3,
143 . 3,5,6,
144 . 6,5,1,
145 . 1,3,6/
146C liste chainee polygones
147 TYPE polygone
148 INTEGER IZ(3), NNSP
149 INTEGER, DIMENSION(:), POINTER :: IPOLY, IELNOD
150 INTEGER, DIMENSION(:,:), POINTER :: NREF
151 my_real
152 . , DIMENSION(:), POINTER :: rpoly
153 my_real
154 . , DIMENSION(:,:), POINTER :: aref
155 TYPE(polygone), POINTER :: PTR
156 END TYPE POLYGONE
157 TYPE(polygone), POINTER :: FIRST, PTR_PREC, PTR_CUR, PTR_TMP,
158 . PTR_OLD, FIRST2, PTR_CUR2, PTR_PREC2,
159 . ptr_tmp2
160C liste chainee polyhedres
161 TYPE polyhedre
162 INTEGER RANK
163 INTEGER, DIMENSION(:), POINTER :: POLH
164 TYPE(POLYHEDRE), POINTER :: PTR
165 END TYPE polyhedre
166 TYPE(polyhedre), POINTER :: PHFIRST, PH_PREC, PH_CUR, PH_TMP
167C
168C Structure de donnees maillage volumes finis
169C - NNS : Nombre de nouveaux noeuds ( = IVOLU(46) )
170C - NNTR : Nombre de nouveaux triangles ( = IVOLU(47) )
171C - NPOLY : Nombre de polygones ( = IVOLU(48) )
172C - NPOLH : Nombre de polyhedres ( volumes finis) ( = IVOLU(49) )
173C
174C - IFVNOD(NNS) : Triangle airbag de reference pour le nouveau noeud
175C - RFVNOD(2,NNS) : Coordonnees locales du noeud dans le triangle
176C
177C - IFVTRI(6,NNTR) : Connectivite nouveaux triangles (1->3)
178C Element de reference si appuye sur surface (4)
179C Polyhedres connectes si interne (5->6)
180C
181C - IFVPOLY(NNTR) : Attribution triangles-polygones
182C - IFVTADR(NPOLY+1) : Adresses dans le tableau precedent
183C
184C - IFVPOLH(NPOLY) : Attribution polygones-polyhedres
185C - IFVPADR(NPOLH+1) : Adresses dans le tableau precedent
186C
187 ifv=ivolu(45)
188 nnsa=fvspmd(ifv)%NNSA
189 ALLOCATE(xxxsa(3,nnsa))
190 IF (nspmd == 1) THEN
191C traitement necessaire pour rester p/on
192 DO i=1,fvspmd(ifv)%NN_L
193 i1=fvspmd(ifv)%IBUF_L(1,i)
194 i2=fvspmd(ifv)%IBUF_L(2,i)
195 xxx(1,i1)=x(1,i2)
196 xxx(2,i1)=x(2,i2)
197 xxx(3,i1)=x(3,i2)
198 ENDDO
199 DO i=1,fvspmd(ifv)%NNA_L
200 i1=fvspmd(ifv)%IBUFA_L(1,i)
201 i2=fvspmd(ifv)%IBUFA_L(2,i)
202 xxxa(1,i1)=x(1,i2)
203 xxxa(2,i1)=x(2,i2)
204 xxxa(3,i1)=x(3,i2)
205 ENDDO
206 DO i=1,fvspmd(ifv)%NNSA_L
207 i1=fvspmd(ifv)%IBUFSA_L(1,i)
208 i2=fvspmd(ifv)%IBUFSA_L(2,i)
209 xxxsa(1,i1)=x(1,i2)
210 xxxsa(2,i1)=x(2,i2)
211 xxxsa(3,i1)=x(3,i2)
212 ENDDO
213 ELSE
214 CALL spmd_fvb_gath(ifv, x, xxx, xxxa, xxxsa,
215 . 2 )
216 IF (ispmd/=fvspmd(ifv)%PMAIN-1) RETURN
217 ENDIF
218 NULLIFY(first)
219 NULLIFY(phfirst)
220C
221 ilvout=ivolu(44)
222C
223 nlayer=ivolu(40)
224 nfacmax=ivolu(41)
225 nppmax=ivolu(42)
226C
227 DO i=1,nbric
228 tbric(7,i)=0
229 DO j=1,6
230 tbric(7+j,i)=0
231 ENDDO
232 ENDDO
233C---------------------------------------------------
234C Normales elementaires et volume de l'airbag
235C---------------------------------------------------
236 volg=zero
237 DO iel=1,nel
238 n1=elem(1,iel)
239 n2=elem(2,iel)
240 n3=elem(3,iel)
241 x1=xxx(1,n1)
242 x2=xxx(1,n2)
243 x3=xxx(1,n3)
244 y1=xxx(2,n1)
245 y2=xxx(2,n2)
246 y3=xxx(2,n3)
247 z1=xxx(3,n1)
248 z2=xxx(3,n2)
249 z3=xxx(3,n3)
250 x12=x2-x1
251 y12=y2-y1
252 z12=z2-z1
253 x13=x3-x1
254 y13=y3-y1
255 z13=z3-z1
256 nrx=y12*z13-z12*y13
257 nry=z12*x13-x12*z13
258 nrz=x12*y13-y12*x13
259 area2=sqrt(nrx**2+nry**2+nrz**2)
260 elarea(iel)=half*area2
261 norm(1,iel)=nrx/area2
262 norm(2,iel)=nry/area2
263 norm(3,iel)=nrz/area2
264C
265 volg=volg+one_over_6*(x1*nrx+y1*nry+z1*nrz)
266 ENDDO
267C
268 DO iel=1,nela
269 n1=elema(1,iel)
270 n2=elema(2,iel)
271 n3=elema(3,iel)
272 IF (tagela(iel)>0) THEN
273 x1=xxx(1,n1)
274 y1=xxx(2,n1)
275 z1=xxx(3,n1)
276 x2=xxx(1,n2)
277 y2=xxx(2,n2)
278 z2=xxx(3,n2)
279 x3=xxx(1,n3)
280 y3=xxx(2,n3)
281 z3=xxx(3,n3)
282 ELSEIF (tagela(iel)<0) THEN
283 x1=xxxa(1,n1)
284 y1=xxxa(2,n1)
285 z1=xxxa(3,n1)
286 x2=xxxa(1,n2)
287 y2=xxxa(2,n2)
288 z2=xxxa(3,n2)
289 x3=xxxa(1,n3)
290 y3=xxxa(2,n3)
291 z3=xxxa(3,n3)
292 ENDIF
293 x12=x2-x1
294 y12=y2-y1
295 z12=z2-z1
296 x13=x3-x1
297 y13=y3-y1
298 z13=z3-z1
299 nrx=y12*z13-z12*y13
300 nry=z12*x13-x12*z13
301 nrz=x12*y13-y12*x13
302 area2=sqrt(nrx**2+nry**2+nrz**2)
303 norma(1,iel)=nrx/area2
304 norma(2,iel)=nry/area2
305 norma(3,iel)=nrz/area2
306 ENDDO
307C---------------------------------------------------
308C Creation de tous les polygones
309C---------------------------------------------------
310 npoly=0
311 nns=0
312 npoly2=0
313 nns2=0
314 IF (nela==0) THEN
315 npoly=0
316 npolh=0
317 GOTO 370
318 ENDIF
319C
320 DO i=1,nbric
321 itagb(i)=0
322 ENDDO
323C 1. Facettes airbag coupees
324 IF (ilvout/=0) THEN
325 WRITE(istdo,*)
326 WRITE(istdo,'(A25,I10,A23)')
327 . ' ** MONITORED VOLUME ID: ',ivolu(1),' - BUILDING POLYGONS **'
328 ENDIF
329C
330C nullify sinon test sur associated vrai second appel fvmesh1
331 NULLIFY(first2)
332 DO i=1,nbric
333C IF (ILVOUT<0) CALL PROGBAR_C(I,NBRIC)
334C
335 ptr_old => ptr_cur
336 npoly_old=npoly
337 nns_old=nns
338 100 CONTINUE
339 IF (ALLOCATED(facet)) DEALLOCATE(facet)
340 IF (ALLOCATED(tri)) DEALLOCATE(tri)
341 IF (ALLOCATED(normt)) DEALLOCATE(normt)
342 IF (ALLOCATED(poly)) DEALLOCATE(poly)
343 ALLOCATE(facet(6,1+nfacmax), tri(nfacmax,4),
344 . normt(3,nfacmax), poly(3,nvmax))
345 DO j=1,6
346 facet(j,1)=0
347 ENDDO
348C
349 xbmax=-ep30
350 ybmax=-ep30
351 zbmax=-ep30
352 xbmin=ep30
353 ybmin=ep30
354 zbmin=ep30
355 xc=zero
356 yc=zero
357 zc=zero
358 DO j=1,8
359 xx=xb(1,bric(j,i))
360 yy=xb(2,bric(j,i))
361 zz=xb(3,bric(j,i))
362 xbmax=max(xbmax,xx)
363 ybmax=max(ybmax,yy)
364 zbmax=max(zbmax,zz)
365 xbmin=min(xbmin,xx)
366 ybmin=min(ybmin,yy)
367 zbmin=min(zbmin,zz)
368 xc=xc+one_over_8*xx
369 yc=yc+one_over_8*yy
370 zc=zc+one_over_8*zz
371 ENDDO
372C Passage repere local brique
373 pp(1,1)=sfac(4,2,i)
374 pp(2,1)=sfac(4,3,i)
375 pp(3,1)=sfac(4,4,i)
376 pp(1,2)=sfac(5,2,i)
377 pp(2,2)=sfac(5,3,i)
378 pp(3,2)=sfac(5,4,i)
379 pp(1,3)=sfac(2,2,i)
380 pp(2,3)=sfac(2,3,i)
381 pp(3,3)=sfac(2,4,i)
382C
383 xx=xb(1,bric(7,i))
384 yy=xb(2,bric(7,i))
385 zz=xb(3,bric(7,i))
386 xl7(1)=pp(1,1)*(xx-xc)+pp(2,1)*(yy-yc)+pp(3,1)*(zz-zc)
387 xl7(2)=pp(1,2)*(xx-xc)+pp(2,2)*(yy-yc)+pp(3,2)*(zz-zc)
388 xl7(3)=pp(1,3)*(xx-xc)+pp(2,3)*(yy-yc)+pp(3,3)*(zz-zc)
389 bcenter(1)=zero
390 bcenter(2)=zero
391 bcenter(3)=zero
392 bhalfsize(1)=xl7(1)
393 bhalfsize(2)=xl7(2)
394 bhalfsize(3)=xl7(3)
395 info=0
396 DO iel=1,nela
397 n1=elema(1,iel)
398 n2=elema(2,iel)
399 n3=elema(3,iel)
400 IF (tagela(iel)>0) THEN
401 x1=xxx(1,n1)
402 y1=xxx(2,n1)
403 z1=xxx(3,n1)
404 x2=xxx(1,n2)
405 y2=xxx(2,n2)
406 z2=xxx(3,n2)
407 x3=xxx(1,n3)
408 y3=xxx(2,n3)
409 z3=xxx(3,n3)
410 ELSEIF (tagela(iel)<0) THEN
411 x1=xxxa(1,n1)
412 y1=xxxa(2,n1)
413 z1=xxxa(3,n1)
414 x2=xxxa(1,n2)
415 y2=xxxa(2,n2)
416 z2=xxxa(3,n2)
417 x3=xxxa(1,n3)
418 y3=xxxa(2,n3)
419 z3=xxxa(3,n3)
420 ENDIF
421 xtmax=max(x1,x2,x3)
422 ytmax=max(y1,y2,y3)
423 ztmax=max(z1,z2,z3)
424 xtmin=min(x1,x2,x3)
425 ytmin=min(y1,y2,y3)
426 ztmin=min(z1,z2,z3)
427 IF (xbmax<xtmin.OR.ybmax<ytmin.OR.zbmax<ztmin.OR.
428 . xbmin>xtmax.OR.ybmin>ytmax.OR.zbmin>ztmax)
429 . cycle
430C
431 tverts(1)=pp(1,1)*(x1-xc)+pp(2,1)*(y1-yc)+pp(3,1)*(z1-zc)
432 tverts(2)=pp(1,2)*(x1-xc)+pp(2,2)*(y1-yc)+pp(3,2)*(z1-zc)
433 tverts(3)=pp(1,3)*(x1-xc)+pp(2,3)*(y1-yc)+pp(3,3)*(z1-zc)
434 tverts(4)=pp(1,1)*(x2-xc)+pp(2,1)*(y2-yc)+pp(3,1)*(z2-zc)
435 tverts(5)=pp(1,2)*(x2-xc)+pp(2,2)*(y2-yc)+pp(3,2)*(z2-zc)
436 tverts(6)=pp(1,3)*(x2-xc)+pp(2,3)*(y2-yc)+pp(3,3)*(z2-zc)
437 tverts(7)=pp(1,1)*(x3-xc)+pp(2,1)*(y3-yc)+pp(3,1)*(z3-zc)
438 tverts(8)=pp(1,2)*(x3-xc)+pp(2,2)*(y3-yc)+pp(3,2)*(z3-zc)
439 tverts(9)=pp(1,3)*(x3-xc)+pp(2,3)*(y3-yc)+pp(3,3)*(z3-zc)
440C
441 CALL tribox3(icut, bcenter, bhalfsize, tverts)
442C Liste elargie pour faces laterales
443 IF (icut==0) THEN
444 tole=em5
445* TOLE=ZERO
446 xg=third*(x1+x2+x3)
447 yg=third*(y1+y2+y3)
448 zg=third*(z1+z2+z3)
449 x1=xg+(one+tole)*(x1-xg)
450 y1=yg+(one+tole)*(y1-yg)
451 z1=zg+(one+tole)*(z1-zg)
452 x2=xg+(one+tole)*(x2-xg)
453 y2=yg+(one+tole)*(y2-yg)
454 z2=zg+(one+tole)*(z2-zg)
455 x3=xg+(one+tole)*(x3-xg)
456 y3=yg+(one+tole)*(y3-yg)
457 z3=zg+(one+tole)*(z3-zg)
458C
459 tverts(1)=pp(1,1)*(x1-xc)+pp(2,1)*(y1-yc)+pp(3,1)*(z1-zc)
460 tverts(2)=pp(1,2)*(x1-xc)+pp(2,2)*(y1-yc)+pp(3,2)*(z1-zc)
461 tverts(3)=pp(1,3)*(x1-xc)+pp(2,3)*(y1-yc)+pp(3,3)*(z1-zc)
462 tverts(4)=pp(1,1)*(x2-xc)+pp(2,1)*(y2-yc)+pp(3,1)*(z2-zc)
463 tverts(5)=pp(1,2)*(x2-xc)+pp(2,2)*(y2-yc)+pp(3,2)*(z2-zc)
464 tverts(6)=pp(1,3)*(x2-xc)+pp(2,3)*(y2-yc)+pp(3,3)*(z2-zc)
465 tverts(7)=pp(1,1)*(x3-xc)+pp(2,1)*(y3-yc)+pp(3,1)*(z3-zc)
466 tverts(8)=pp(1,2)*(x3-xc)+pp(2,2)*(y3-yc)+pp(3,2)*(z3-zc)
467 tverts(9)=pp(1,3)*(x3-xc)+pp(2,3)*(y3-yc)+pp(3,3)*(z3-zc)
468C
469 CALL tribox3(icut, bcenter, bhalfsize, tverts)
470 IF (icut==1) icut=2
471 ENDIF
472C
473 IF (icut>=1) THEN
474 IF (icut==1) THEN
475 tbric(7,i)=2
476 tmptri(1,1)=x1
477 tmptri(2,1)=y1
478 tmptri(3,1)=z1
479 tmptri(1,2)=x2
480 tmptri(2,2)=y2
481 tmptri(3,2)=z2
482 tmptri(1,3)=x3
483 tmptri(2,3)=y3
484 tmptri(3,3)=z3
485 DO j=1,8
486 tmpbox(1,j)=xb(1,bric(j,i))
487 tmpbox(2,j)=xb(2,bric(j,i))
488 tmpbox(3,j)=xb(3,bric(j,i))
489 ENDDO
490 DO j=1,6
491 tmpnorm(1,j)=-sfac(j,2,i)
492 tmpnorm(2,j)=-sfac(j,3,i)
493 tmpnorm(3,j)=-sfac(j,4,i)
494 ENDDO
495 CALL itribox(tmptri, tmpbox, tmpnorm, nverts, poly,
496 . nvmax )
497 IF (nverts>0) THEN
498 npoly=npoly+1
499 IF (.NOT.ASSOCIATED(first)) THEN
500 ALLOCATE(first)
501 ptr_cur => first
502 ELSE
503 ALLOCATE(ptr_cur)
504 ptr_prec%PTR => ptr_cur
505 ENDIF
506 ALLOCATE(ptr_cur%IPOLY(6+nverts),
507 . ptr_cur%IELNOD(nverts),
508 . ptr_cur%RPOLY(4+3*nverts))
509 ptr_cur%IPOLY(1)=1
510 ptr_cur%IPOLY(2)=nverts
511 ptr_cur%IPOLY(3)=iel
512 ptr_cur%IPOLY(4)=i
513 ptr_cur%IPOLY(5)=0
514 ptr_cur%IPOLY(6)=0
515 ptr_cur%RPOLY(1)=zero
516 ptr_cur%RPOLY(2)=norma(1,iel)
517 ptr_cur%RPOLY(3)=norma(2,iel)
518 ptr_cur%RPOLY(4)=norma(3,iel)
519 DO j=1,nverts
520 nns=nns+1
521 ptr_cur%IPOLY(6+j)=nns
522 ptr_cur%IELNOD(j)=iel
523 ptr_cur%RPOLY(4+3*(j-1)+1)=poly(1,j)
524 ptr_cur%RPOLY(4+3*(j-1)+2)=poly(2,j)
525 ptr_cur%RPOLY(4+3*(j-1)+3)=poly(3,j)
526 ENDDO
527 ptr_prec => ptr_cur
528 ENDIF
529 ENDIF
530C Facettes coupees (1 quadrangle=2 triangles)
531 tole=em5
532* TOLE=ZERO
533 xg=third*(x1+x2+x3)
534 yg=third*(y1+y2+y3)
535 zg=third*(z1+z2+z3)
536 x1=xg+(one+tole)*(x1-xg)
537 y1=yg+(one+tole)*(y1-yg)
538 z1=zg+(one+tole)*(z1-zg)
539 x2=xg+(one+tole)*(x2-xg)
540 y2=yg+(one+tole)*(y2-yg)
541 z2=zg+(one+tole)*(z2-zg)
542 x3=xg+(one+tole)*(x3-xg)
543 y3=yg+(one+tole)*(y3-yg)
544 z3=zg+(one+tole)*(z3-zg)
545C
546 fv0(1)=x1
547 fv0(2)=y1
548 fv0(3)=z1
549 fv1(1)=x2
550 fv1(2)=y2
551 fv1(3)=z2
552 fv2(1)=x3
553 fv2(2)=y3
554 fv2(3)=z3
555 DO j=1,6
556 nf1=bric(fac(1,j),i)
557 nf2=bric(fac(2,j),i)
558 nf3=bric(fac(3,j),i)
559 nf4=bric(fac(4,j),i)
560 fu0(1)=xb(1,nf1)
561 fu0(2)=xb(2,nf1)
562 fu0(3)=xb(3,nf1)
563 fu1(1)=xb(1,nf2)
564 fu1(2)=xb(2,nf2)
565 fu1(3)=xb(3,nf2)
566 fu2(1)=xb(1,nf3)
567 fu2(2)=xb(2,nf3)
568 fu2(3)=xb(3,nf3)
569C
570 CALL tritri3(icut, fv0, fv1, fv2, fu0, fu1, fu2)
571 IF (icut==1) THEN
572 tbric(7+j,i)=2
573 ns=facet(j,1)
574 ns=ns+1
575 facet(j,1)=ns
576 IF (ns>nfacmax) THEN
577 info=1
578 ELSE
579 facet(j,1+ns)=iel
580 ENDIF
581 cycle
582 ENDIF
583C
584 fu1(1)=xb(1,nf3)
585 fu1(2)=xb(2,nf3)
586 fu1(3)=xb(3,nf3)
587 fu2(1)=xb(1,nf4)
588 fu2(2)=xb(2,nf4)
589 fu2(3)=xb(3,nf4)
590C
591 CALL tritri3(icut, fv0, fv1, fv2, fu0, fu1, fu2)
592 IF (icut==1) THEN
593 tbric(7+j,i)=2
594 ns=facet(j,1)
595 ns=ns+1
596 facet(j,1)=ns
597 IF (ns>nfacmax) THEN
598 info=1
599 ELSE
600 facet(j,1+ns)=iel
601 ENDIF
602 ENDIF
603 ENDDO
604 ENDIF
605 ENDDO
606C
607 IF (info==1) THEN
608 nsmax=0
609 DO j=1,6
610 nsmax=max(nsmax,facet(j,1))
611 ENDDO
612 nfacmax=nsmax
613C Destruction des polygones crees pour rien
614 IF (npoly_old>0) THEN
615 ptr_cur => ptr_old%PTR
616 ELSE
617 ptr_cur => first
618 ENDIF
619 DO j=1,npoly-npoly_old
620 ptr_tmp => ptr_cur%PTR
621 DEALLOCATE(ptr_cur%IPOLY, ptr_cur%RPOLY,
622 . ptr_cur%IELNOD)
623 DEALLOCATE(ptr_cur)
624 ptr_cur => ptr_tmp
625 ENDDO
626 IF (npoly_old>0) THEN
627 ptr_prec => ptr_old
628 ELSE
629 NULLIFY(first)
630 ENDIF
631 npoly=npoly_old
632 nns=nns_old
633C
634 GOTO 100
635 ENDIF
636C 2. Faces laterales
637 IF (tbric(7,i)<=1) THEN
638 DEALLOCATE(facet, tri, normt, poly)
639 cycle
640 END IF
641 DO j=1,6
642 nv=tbric(j,i)
643 IF (nv==0) cycle
644 IF (itagb(nv)==1) cycle
645 IF (tbric(7+j,i)==2) THEN
646 DO k=1,4
647 kk=fac(k,j)
648 quad(1,k)=xb(1,bric(kk,i))
649 quad(2,k)=xb(2,bric(kk,i))
650 quad(3,k)=xb(3,bric(kk,i))
651 ENDDO
652 ns=facet(j,1)
653 DO k=1,ns
654 iel=facet(j,1+k)
655 IF (tagela(iel)>0) THEN
656 DO l=1,3
657 ll=elema(l,iel)
658 tri(k,l)=ll
659 ENDDO
660 ELSEIF (tagela(iel)<0) THEN
661 DO l=1,3
662 ll=-elema(l,iel)
663 tri(k,l)=ll
664 ENDDO
665 ENDIF
666 tri(k,4)=iel
667 normt(1,k)=norma(1,iel)
668 normt(2,k)=norma(2,iel)
669 normt(3,k)=norma(3,iel)
670 ENDDO
671 DO k=1,4
672 normf(1,k)=sfac(facnor(k,j),2,i)
673 normf(2,k)=sfac(facnor(k,j),3,i)
674 normf(3,k)=sfac(facnor(k,j),4,i)
675 ENDDO
676 nr(1)=sfac(j,2,i)
677 nr(2)=sfac(j,3,i)
678 nr(3)=sfac(j,4,i)
679C
680 nnp=0
681 npolmax=nlayer
682C
683 200 CONTINUE
684 nrpmax=nppmax*3+4
685 IF (ALLOCATED(ipoly)) DEALLOCATE(ipoly)
686 IF (ALLOCATED(rpoly)) DEALLOCATE(rpoly)
687 IF (ALLOCATED(ielnod)) DEALLOCATE(ielnod)
688 ALLOCATE(ipoly(6+nppmax+1+npolmax,npolmax),
689 . rpoly(nrpmax+3*npolmax,npolmax),
690 . ielnod(nppmax,npolmax))
691C
692 CALL facepoly(quad, tri, ns, ipoly, rpoly,
693 . nr, normf, normt, nfacmax, nnp,
694 . nrpmax, i, nv, dxm , npolmax,
695 . nppmax, info, ielnod, xxx, elema,
696 . ibuf, nela, i, j, ivolu(1),
697 . ilvout, ibufa, tagela, xxxa )
698 IF (info==1) GOTO 200
699C
700 DO n=1,nnp
701 IF (ipoly(1,n)==-1) cycle
702 npoly2=npoly2+1
703 IF (.NOT.ASSOCIATED(first2)) THEN
704 ALLOCATE(first2)
705 ptr_cur2 => first2
706 ELSE
707 ALLOCATE(ptr_cur2)
708 ptr_prec2%PTR => ptr_cur2
709 ENDIF
710 nn=ipoly(2,n)
711 nhol=ipoly(6+nn+1,n)
712 ALLOCATE(ptr_cur2%IPOLY(6+nn+1+nhol),
713 . ptr_cur2%IELNOD(nn),
714 . ptr_cur2%RPOLY(4+3*nn+3*nhol))
715 DO m=1,6
716 ptr_cur2%IPOLY(m)=ipoly(m,n)
717 ENDDO
718 DO m=1,4
719 ptr_cur2%RPOLY(m)=rpoly(m,n)
720 ENDDO
721 DO m=1,ipoly(2,n)
722 nns2=nns2+1
723 ptr_cur2%IPOLY(6+m)=nns2
724 mm=ielnod(m,n)
725 ptr_cur2%IELNOD(m)=facet(j,1+mm)
726 ptr_cur2%RPOLY(4+3*(m-1)+1)=rpoly(4+3*(m-1)+1,n)
727 ptr_cur2%RPOLY(4+3*(m-1)+2)=rpoly(4+3*(m-1)+2,n)
728 ptr_cur2%RPOLY(4+3*(m-1)+3)=rpoly(4+3*(m-1)+3,n)
729 ENDDO
730 ptr_cur2%IPOLY(6+nn+1)=nhol
731 DO m=1,nhol
732 ptr_cur2%IPOLY(6+nn+1+m)=ipoly(6+nn+1+m,n)
733 ptr_cur2%RPOLY(4+3*nn+3*(m-1)+1)=
734 . rpoly(4+3*nn+3*(m-1)+1,n)
735 ptr_cur2%RPOLY(4+3*nn+3*(m-1)+2)=
736 . rpoly(4+3*nn+3*(m-1)+2,n)
737 ptr_cur2%RPOLY(4+3*nn+3*(m-1)+3)=
738 . rpoly(4+3*nn+3*(m-1)+3,n)
739 ENDDO
740 ptr_prec2 => ptr_cur2
741 ENDDO
742C
743 DEALLOCATE(ipoly, rpoly, ielnod)
744 ENDIF
745 ENDDO
746 itagb(i)=1
747C
748 DEALLOCATE(facet, tri, normt, poly)
749 ENDDO
750C Concatenation des deux listes
751 ptr_cur2 => first2
752 ptr_prec => ptr_cur
753 DO i=1,npoly2
754 npoly=npoly+1
755 ALLOCATE(ptr_cur)
756 ptr_prec%PTR => ptr_cur
757 nn=ptr_cur2%IPOLY(2)
758 nhol=ptr_cur2%IPOLY(6+nn+1)
759 ALLOCATE(ptr_cur%IPOLY(6+nn+1+nhol),
760 . ptr_cur%IELNOD(nn),
761 . ptr_cur%RPOLY(4+3*nn+3*nhol))
762 DO j=1,6
763 ptr_cur%IPOLY(j)=ptr_cur2%IPOLY(j)
764 ENDDO
765 DO j=1,4
766 ptr_cur%RPOLY(j)=ptr_cur2%RPOLY(j)
767 ENDDO
768 DO j=1,nn
769 ptr_cur%IPOLY(6+j)=nns+ptr_cur2%IPOLY(6+j)
770 ptr_cur%IELNOD(j)=ptr_cur2%IELNOD(j)
771 ptr_cur%RPOLY(4+3*(j-1)+1)=ptr_cur2%RPOLY(4+3*(j-1)+1)
772 ptr_cur%RPOLY(4+3*(j-1)+2)=ptr_cur2%RPOLY(4+3*(j-1)+2)
773 ptr_cur%RPOLY(4+3*(j-1)+3)=ptr_cur2%RPOLY(4+3*(j-1)+3)
774 ENDDO
775 ptr_cur%IPOLY(6+nn+1)=nhol
776 DO j=1,nhol
777 ptr_cur%IPOLY(6+nn+1+j)=ptr_cur2%IPOLY(6+nn+1+j)
778 ptr_cur%RPOLY(4+3*nn+3*(j-1)+1)=
779 . ptr_cur2%RPOLY(4+3*nn+3*(j-1)+1)
780 ptr_cur%RPOLY(4+3*nn+3*(j-1)+2)=
781 . ptr_cur2%RPOLY(4+3*nn+3*(j-1)+2)
782 ptr_cur%RPOLY(4+3*nn+3*(j-1)+3)=
783 . ptr_cur2%RPOLY(4+3*nn+3*(j-1)+3)
784 ENDDO
785 ptr_tmp2 => ptr_cur2%PTR
786 DEALLOCATE(ptr_cur2%IPOLY, ptr_cur2%RPOLY, ptr_cur2%IELNOD)
787 DEALLOCATE(ptr_cur2)
788 ptr_cur2 => ptr_tmp2
789 ptr_prec => ptr_cur
790 ENDDO
791C
792 nns=nns+nns2
793C---------------------------------------------------
794C Decoupage des polygones selon la verticale locale
795C---------------------------------------------------
796 nbz=ivolu(65)
797 IF (nbz>1) THEN
798 ptr_cur => first
799 DO i=1,npoly
800 ptr_cur%NNSP=0
801 ptr_cur => ptr_cur%PTR
802 ENDDO
803C
804 vx3=rvolu(35)
805 vy3=rvolu(36)
806 vz3=rvolu(37)
807 vx1=rvolu(38)
808 vy1=rvolu(39)
809 vz1=rvolu(40)
810C Repere local
811 vnorm=sqrt(vx3**2+vy3**2+vz3**2)
812 vx3=vx3/vnorm
813 vy3=vy3/vnorm
814 vz3=vz3/vnorm
815 ss=vx3*vx1+vy3*vy1+vz3*vz1
816 vx1=vx1-ss*vx3
817 vy1=vy1-ss*vy3
818 vz1=vz1-ss*vz3
819 vnorm=sqrt(vx1**2+vy1**2+vz1**2)
820 vx1=vx1/vnorm
821 vy1=vy1/vnorm
822 vz1=vz1/vnorm
823 vx2=vy3*vz1-vz3*vy1
824 vy2=vz3*vx1-vx3*vz1
825 vz2=vx3*vy1-vy3*vx1
826C
827 x0=rvolu(41)
828 y0=rvolu(42)
829 z0=rvolu(43)
830 lz=rvolu(53)
831 dz=two*lz/nbz
832 dxm=min(dxm,dz)
833C
834 zbmin=ep30
835 zbmax=-ep30
836 DO iel=1,nel
837 n1=elem(1,iel)
838 n2=elem(2,iel)
839 n3=elem(3,iel)
840 x1=xxx(1,n1)
841 x2=xxx(1,n2)
842 x3=xxx(1,n3)
843 y1=xxx(2,n1)
844 y2=xxx(2,n2)
845 y3=xxx(2,n3)
846 z1=xxx(3,n1)
847 z2=xxx(3,n2)
848 z3=xxx(3,n3)
849 x12=x2-x1
850 y12=y2-y1
851 z12=z2-z1
852 x13=x3-x1
853 y13=y3-y1
854 z13=z3-z1
855 zl1=(x1-x0)*vx3+(y1-y0)*vy3+(z1-z0)*vz3
856 zl2=(x2-x0)*vx3+(y2-y0)*vy3+(z2-z0)*vz3
857 zl3=(x3-x0)*vx3+(y3-y0)*vy3+(z3-z0)*vz3
858 zbmin=min(zbmin,zl1)
859 zbmin=min(zbmin,zl2)
860 zbmin=min(zbmin,zl3)
861 zbmax=max(zbmax,zl1)
862 zbmax=max(zbmax,zl2)
863 zbmax=max(zbmax,zl3)
864 ENDDO
865C Clipping des polygones
866 x0=x0-lz*vx3
867 y0=y0-lz*vy3
868 z0=z0-lz*vz3
869 zlc=-lz
870 ALLOCATE(inedge(6,npoly*nppmax), rnedge(6,npoly*nppmax))
871 nbnedge=0
872 nns3=0
873 npoly_new=npoly
874 iiz=0
875 DO i=1,nbz+1
876 IF (zlc<zbmin.OR.zlc>zbmax) THEN
877 x0=x0+dz*vx3
878 y0=y0+dz*vy3
879 z0=z0+dz*vz3
880 zlc=zlc+dz
881 cycle
882 ENDIF
883 iiz=iiz+1
884 ptr_cur => first
885 DO j=1,npoly
886 zlmin=ep30
887 zlmax=-ep30
888 DO k=1,ptr_cur%IPOLY(2)
889 xx=ptr_cur%RPOLY(4+3*(k-1)+1)
890 yy=ptr_cur%RPOLY(4+3*(k-1)+2)
891 zz=ptr_cur%RPOLY(4+3*(k-1)+3)
892 zl=(xx-x0)*vx3+(yy-y0)*vy3+(zz-z0)*vz3
893 zlmin=min(zlmin,zl)
894 zlmax=max(zlmax,zl)
895 ENDDO
896 IF (zlmin*zlmax<zero) THEN
897 ity=ptr_cur%IPOLY(1)
898 nn=ptr_cur%IPOLY(2)
899 nhol=0
900 IF (ity==2) nhol=ptr_cur%IPOLY(6+nn+1)
901 ALLOCATE(ipoly(6+2*nn+1+nhol,nn),
902 . rpoly(4+3*2*nn+3*nhol,nn),
903 . ielnod(2*nn,nn),
904 . nref(2,nn), aref(4,nn),
905 . iz(3,nn))
906 CALL gpolcut(
907 . ipoly, rpoly, ptr_cur%IPOLY, ptr_cur%RPOLY, inedge,
908 . rnedge, nbnedge, vx3, vy3, vz3,
909 . x0, y0, z0, nref, aref,
910 . nn, nhol, iiz, iz, nns3,
911 . nnp , nnsp, ielnod, ptr_cur%IELNOD)
912C
913 ptr_tmp => ptr_cur%PTR
914 npoly_new=npoly_new-1
915 DO n=1,nnp
916 npoly_new=npoly_new+1
917 IF (n==1) THEN
918 DEALLOCATE(ptr_cur%IPOLY, ptr_cur%RPOLY,
919 . ptr_cur%IELNOD)
920 ELSE
921 ALLOCATE(ptr_cur)
922 ptr_prec%PTR => ptr_cur
923 ptr_cur%NNSP=0
924 ENDIF
925 nn=ipoly(2,n)
926 nhol=ipoly(6+nn+1,n)
927 ALLOCATE(ptr_cur%IPOLY(6+nn+1+nhol),
928 . ptr_cur%IELNOD(nn),
929 . ptr_cur%RPOLY(4+3*nn+3*nhol))
930 DO m=1,6
931 ptr_cur%IPOLY(m)=ipoly(m,n)
932 ENDDO
933 DO m=1,4
934 ptr_cur%RPOLY(m)=rpoly(m,n)
935 ENDDO
936 DO m=1,nn
937 mm=ipoly(6+m,n)
938 ptr_cur%IPOLY(6+m)=mm
939 ptr_cur%IELNOD(m)=ielnod(m,n)
940 ptr_cur%RPOLY(4+3*(m-1)+1)=rpoly(4+3*(m-1)+1,n)
941 ptr_cur%RPOLY(4+3*(m-1)+2)=rpoly(4+3*(m-1)+2,n)
942 ptr_cur%RPOLY(4+3*(m-1)+3)=rpoly(4+3*(m-1)+3,n)
943 ENDDO
944 nhol=ipoly(6+nn+1,n)
945 ptr_cur%IPOLY(6+nn+1)=nhol
946 DO m=1,nhol
947 ptr_cur%IPOLY(6+nn+1+m)=ipoly(6+nn+1+m,n)
948 ptr_cur%RPOLY(4+3*nn+3*(m-1)+1)=
949 . rpoly(4+3*nn+3*(m-1)+1,n)
950 ptr_cur%RPOLY(4+3*nn+3*(m-1)+2)=
951 . rpoly(4+3*nn+3*(m-1)+2,n)
952 ptr_cur%RPOLY(4+3*nn+3*(m-1)+3)=
953 . rpoly(4+3*nn+3*(m-1)+3,n)
954 ENDDO
955 ptr_cur%IZ(1)=1
956 ptr_cur%IZ(2)=iz(2,n)
957 IF (n==nnp) THEN
958 ptr_cur%NNSP=nnsp
959 ALLOCATE(ptr_cur%NREF(3,nnsp),
960 . ptr_cur%AREF(4,nnsp))
961 DO m=1,nnsp
962 nns3=nns3+1
963 ptr_cur%NREF(1,m)=nns3
964 ptr_cur%NREF(2,m)=nref(1,m)
965 ptr_cur%NREF(3,m)=nref(2,m)
966 ptr_cur%AREF(1,m)=aref(1,m)
967 ptr_cur%AREF(2,m)=aref(2,m)
968 ptr_cur%AREF(3,m)=aref(3,m)
969 ptr_cur%AREF(4,m)=aref(4,m)
970 ENDDO
971 ENDIF
972 ptr_prec => ptr_cur
973 IF (n==nnp) ptr_cur%PTR => ptr_tmp
974 ENDDO
975C
976 DEALLOCATE(ipoly, rpoly, ielnod, nref, aref, iz)
977 ELSE
978 IF (zlmin==zero) THEN
979 nn=ptr_cur%IPOLY(2)
980 ALLOCATE(nref(2,2*nn), aref(4,2*nn))
981 CALL horiedge(
982 . ptr_cur%IPOLY, ptr_cur%RPOLY, vx3, vy3, vz3,
983 . nbnedge, inedge, rnedge, x0, y0,
984 . z0, iiz , nns3, nref, aref,
985 . nnsp )
986C
987 IF (nnsp>0) THEN
988 ALLOCATE(ptr_cur%NREF(3,nnsp),
989 . ptr_cur%AREF(4,nnsp))
990 ptr_cur%NNSP=nnsp
991 DO n=1,nnsp
992 nns3=nns3+1
993 ptr_cur%NREF(1,n)=nns3
994 ptr_cur%NREF(2,n)=nref(1,n)
995 ptr_cur%NREF(3,n)=nref(2,n)
996 ptr_cur%AREF(1,n)=aref(1,n)
997 ptr_cur%AREF(2,n)=aref(2,n)
998 ptr_cur%AREF(3,n)=aref(3,n)
999 ptr_cur%AREF(4,n)=aref(4,n)
1000 ENDDO
1001 ENDIF
1002 DEALLOCATE(nref, aref)
1003 ENDIF
1004 IF (zlmin>=zero) THEN
1005 ptr_cur%IZ(1)=1
1006 ptr_cur%IZ(2)=iiz+1
1007 ELSEIF (iiz==1.AND.zlmax<=zero) THEN
1008 ptr_cur%IZ(1)=1
1009 ptr_cur%IZ(2)=1
1010 ENDIF
1011 ptr_prec => ptr_cur
1012 ENDIF
1013 ptr_cur => ptr_cur%PTR
1014 ENDDO
1015 npoly=npoly_new
1016 x0=x0+dz*vx3
1017 y0=y0+dz*vy3
1018 z0=z0+dz*vz3
1019 zlc=zlc+dz
1020 ENDDO
1021C
1022 ALLOCATE(redir(nns))
1023 ptr_cur => first
1024 nns=0
1025 DO i=1,npoly
1026 nn=ptr_cur%IPOLY(2)
1027 DO j=1,nn
1028 jj=ptr_cur%IPOLY(6+j)
1029 IF (jj>0) THEN
1030 nns=nns+1
1031 redir(jj)=nns
1032 ENDIF
1033 ENDDO
1034 ptr_cur => ptr_cur%PTR
1035 ENDDO
1036C
1037 ptr_cur => first
1038 DO i=1,npoly
1039 nnsp=ptr_cur%NNSP
1040 IF (nnsp>0) THEN
1041 DO j=1,nnsp
1042 n1=ptr_cur%NREF(2,j)
1043 n2=ptr_cur%NREF(3,j)
1044 IF (n1>0) ptr_cur%NREF(2,j)=redir(n1)
1045 IF (n2>0) ptr_cur%NREF(3,j)=redir(n2)
1046 ENDDO
1047 ENDIF
1048 ptr_cur => ptr_cur%PTR
1049 ENDDO
1050 DEALLOCATE(redir)
1051C Creation des nouveaux polygones horizontaux
1052 ptr_cur => first
1053 DO i=1,npoly
1054 ptr_prec => ptr_cur
1055 ptr_cur => ptr_cur%PTR
1056 ENDDO
1057 ALLOCATE(ledge(nbnedge))
1058 DO i=1,iiz
1059 DO j=1,nbric
1060 nedge=0
1061 DO k=1,nbnedge
1062 IF (inedge(6,k)/=i) cycle
1063 IF (inedge(1,k)==1.AND.inedge(5,k)/=j) cycle
1064 IF (inedge(1,k)==2.AND.inedge(4,k)/=j.AND.
1065 . inedge(5,k)/=j) cycle
1066 nedge=nedge+1
1067 ledge(nedge)=k
1068 ENDDO
1069 IF (nedge==0) cycle
1070 ALLOCATE(ipoly(6+2*nedge+1+nedge,nedge),
1071 . rpoly(4+6*nedge+3*nedge,nedge),
1072 . iz(3,nedge), ielnod(nedge,nedge))
1073C
1074 CALL horipoly(inedge, rnedge, ledge, nedge, ipoly,
1075 . rpoly, iz, ielnod, nnp, vx3,
1076 . vy3, vz3, i , j )
1077C
1078 DO n=1,nnp
1079 IF (ipoly(1,n)==-1) cycle
1080 npoly=npoly+1
1081 ALLOCATE(ptr_cur)
1082 ptr_prec%PTR => ptr_cur
1083 nn=ipoly(2,n)
1084 nhol=ipoly(6+nn+1,n)
1085 ALLOCATE(ptr_cur%IPOLY(6+nn+1+nhol),
1086 . ptr_cur%RPOLY(4+3*nn+3*nhol),
1087 . ptr_cur%IELNOD(nn))
1088 ptr_cur%NNSP=0
1089 DO m=1,6
1090 ptr_cur%IPOLY(m)=ipoly(m,n)
1091 ENDDO
1092 DO m=1,4
1093 ptr_cur%RPOLY(m)=rpoly(m,n)
1094 ENDDO
1095 DO m=1,nn
1096 ptr_cur%IPOLY(6+m)=ipoly(6+m,n)
1097 ptr_cur%IELNOD(m)=ielnod(m,n)
1098 ptr_cur%RPOLY(4+3*(m-1)+1)=rpoly(4+3*(m-1)+1,n)
1099 ptr_cur%RPOLY(4+3*(m-1)+2)=rpoly(4+3*(m-1)+2,n)
1100 ptr_cur%RPOLY(4+3*(m-1)+3)=rpoly(4+3*(m-1)+3,n)
1101 ENDDO
1102 nhol=ipoly(6+nn+1,n)
1103 ptr_cur%IPOLY(6+nn+1)=nhol
1104 DO m=1,nhol
1105 ptr_cur%IPOLY(6+nn+1+m)=ipoly(6+nn+1+m,n)
1106 ptr_cur%RPOLY(4+3*nn+3*(m-1)+1)=
1107 . rpoly(4+3*nn+3*(m-1)+1,n)
1108 ptr_cur%RPOLY(4+3*nn+3*(m-1)+2)=
1109 . rpoly(4+3*nn+3*(m-1)+2,n)
1110 ptr_cur%RPOLY(4+3*nn+3*(m-1)+3)=
1111 . rpoly(4+3*nn+3*(m-1)+3,n)
1112 ENDDO
1113 DO m=1,3
1114 ptr_cur%IZ(m)=iz(m,n)
1115 ENDDO
1116 ptr_prec => ptr_cur
1117 ENDDO
1118C
1119 DEALLOCATE(ipoly, rpoly, iz, ielnod)
1120 ENDDO
1121 ENDDO
1122 DEALLOCATE(ledge)
1123 ELSE
1124 ptr_cur => first
1125 DO i=1,npoly
1126 ptr_cur%NNSP=0
1127 ptr_cur%IZ(1)=1
1128 ptr_cur%IZ(2)=1
1129 ptr_cur => ptr_cur%PTR
1130 iiz=0
1131 ENDDO
1132 ENDIF
1133C---------------------------------------------------
1134C Construction des polyhedres
1135C---------------------------------------------------
1136 npolh=0
1137 IF (ilvout/=0) WRITE(istdo,'(A25,I10,A24)')
1138 . ' ** MONITORED VOLUME ID: ',ivolu(1),' - BUILDING POLYHEDRA **'
1139C
1140 DO i=1,nbric
1141 IF (ilvout<0) CALL progbar_c(i,nbric)
1142C
1143 IF (tbric(7,i)/=2) cycle
1144C Polygones de la brique
1145 npolb=0
1146 nppmax=0
1147 ptr_cur => first
1148 DO j=1,npoly
1149 ity=ptr_cur%IPOLY(1)
1150 IF ((ity==1.AND.ptr_cur%IPOLY(4)==i).OR.
1151 . (ity==2.AND.
1152 . (ptr_cur%IPOLY(3)==i.OR.ptr_cur%IPOLY(4)==i))) THEN
1153 npolb=npolb+1
1154 nppmax=max(nppmax,ptr_cur%IPOLY(2))
1155 ENDIF
1156 ptr_cur => ptr_cur%PTR
1157 ENDDO
1158 IF (npolb==0) cycle
1159C
1160 nrpmax=4+3*nppmax
1161 ALLOCATE(polb(npolb), ipoly(6+nppmax,npolb),
1162 . rpoly(nrpmax,npolb), redir(npolb))
1163 DO inz=1,iiz+1
1164 npolb=0
1165 ptr_cur => first
1166 DO j=1,npoly
1167 ity=ptr_cur%IPOLY(1)
1168 ityz=ptr_cur%IZ(1)
1169 IF (((ity==1.AND.ptr_cur%IPOLY(4)==i).OR.
1170 . (ity==2.AND.(ptr_cur%IPOLY(3)==i.OR.
1171 . ptr_cur%IPOLY(4)==i)))
1172 . .AND.
1173 . ((ityz==1.AND.ptr_cur%IZ(2)==inz).OR.
1174 . (ityz==2.AND.(ptr_cur%IZ(2)==inz.OR.
1175 . ptr_cur%IZ(3)==inz)))) THEN
1176 npolb=npolb+1
1177 redir(npolb)=j
1178 nn=ptr_cur%IPOLY(2)
1179 DO k=1,6+nn
1180 ipoly(k,npolb)=ptr_cur%IPOLY(k)
1181 ENDDO
1182 DO k=1,4+3*nn
1183 rpoly(k,npolb)=ptr_cur%RPOLY(k)
1184 ENDDO
1185 polb(npolb)=npolb
1186 ENDIF
1187 ptr_cur => ptr_cur%PTR
1188 ENDDO
1189 IF (npolb==0) cycle
1190C
1191 nphmax=npolb
1192 npolhmax=nlayer
1193 300 CONTINUE
1194 IF (ALLOCATED(polh)) DEALLOCATE(polh)
1195 ALLOCATE(polh(nphmax+2,npolhmax))
1196C
1197 CALL polyhedr(ipoly, rpoly , polb, npolb, polh,
1198 . nnp, nrpmax , nphmax, i, dxm ,
1199 . info , npolhmax, nppmax, rvolu(50))
1200 IF (info==1) GOTO 300
1201C Modifications des polygones
1202 ptr_cur => first
1203 npl=1
1204 polc=redir(polb(npl))
1205 DO j=1,npoly
1206 IF (j==polc) THEN
1207 ity=ptr_cur%IPOLY(1)
1208 IF (ity==1) THEN
1209 ptr_cur%IPOLY(5)=npolh+ipoly(5,npl)
1210 ELSEIF (ity==2) THEN
1211 IF (ptr_cur%IPOLY(5)==0) THEN
1212 ptr_cur%IPOLY(5)=npolh+ipoly(5,npl)
1213 ELSE
1214 ptr_cur%IPOLY(6)=npolh+ipoly(6,npl)
1215 ENDIF
1216 ENDIF
1217 IF (npl==npolb) GOTO 350
1218 npl=npl+1
1219 polc=redir(polb(npl))
1220 ENDIF
1221 ptr_cur => ptr_cur%PTR
1222 ENDDO
1223 350 CONTINUE
1224C
1225 DO n=1,nnp
1226 npolh=npolh+1
1227 IF (.NOT.ASSOCIATED(phfirst)) THEN
1228 ALLOCATE(phfirst)
1229 ph_cur => phfirst
1230 ELSE
1231 ALLOCATE(ph_cur)
1232 ph_prec%PTR => ph_cur
1233 ENDIF
1234 nn=polh(1,n)
1235 ALLOCATE(ph_cur%POLH(2+nn))
1236 ph_cur%RANK=npolh
1237 ph_cur%POLH(1)=polh(1,n)
1238 ph_cur%POLH(2)=polh(2,n)
1239 DO m=1,nn
1240 ph_cur%POLH(2+m)=redir(polh(2+m,n))
1241 ENDDO
1242 ph_prec => ph_cur
1243 ENDDO
1244C
1245 ENDDO
1246 DEALLOCATE(ipoly, rpoly, polb, polh, redir)
1247 ENDDO
1248C---------------------------------------------------
1249C Passage listes chainees -> tableaux classiques pour la suite des traitements
1250C---------------------------------------------------
1251 370 CONTINUE
1252C
1253 ptr_cur => first
1254 lenimax=0
1255 lenrmax=0
1256 nns=0
1257 nns2=0
1258 DO i=1,npoly
1259 nn=ptr_cur%IPOLY(2)
1260 nns=nns+nn
1261 nns2=nns2+ptr_cur%NNSP
1262 IF (ptr_cur%IPOLY(1)==1) THEN
1263 lenimax=max(lenimax,6+nn+1)
1264 lenrmax=max(lenrmax,4+3*nn)
1265 ELSEIF (ptr_cur%IPOLY(1)==2) THEN
1266 nhol=ptr_cur%IPOLY(6+nn+1)
1267 lenimax=max(lenimax,6+nn+1+nhol)
1268 lenrmax=max(lenrmax,4+3*nn+3*nhol)
1269 ENDIF
1270 ptr_cur => ptr_cur%PTR
1271 ENDDO
1272 ph_cur => phfirst
1273 nphmax=0
1274 DO i=1,npolh
1275 nn=ph_cur%POLH(1)
1276 nphmax=max(nphmax,nn)
1277 ph_cur => ph_cur%PTR
1278 ENDDO
1279C
1280 npoly_old=npoly
1281 npolh_old=npolh
1282 IF (nba>0) THEN
1283c IF (NSPMD == 1) THEN
1284c ALLOCATE(ITAGN(NUMNOD))
1285c NPOLH=NPOLH+NBA
1286c DO I=1,NBA
1287c ITAGBA(I)=0
1288c ENDDO
1289cC
1290c DO I=1,NUMNOD
1291c ITAGN(I)=0
1292c ENDDO
1293c DO IEL=1,NEL
1294c N1=IBUF(ELEM(1,IEL))
1295c N2=IBUF(ELEM(2,IEL))
1296c N3=IBUF(ELEM(3,IEL))
1297c ITAGN(N1)=1
1298c ITAGN(N2)=1
1299c ITAGN(N3)=1
1300c ENDDO
1301cC
1302c DO I=1,NBA
1303c NFAC=TBA(2,I)
1304c NNP=0
1305c DO J=1,NFAC
1306c ITY=TFACA(2*(J-1)+1,I)
1307c IF (ITY==1) THEN
1308cC Face interne brique/brique
1309c NV=TFACA(2*(J-1)+2,I)
1310c IF (ITAGBA(NV)==0) THEN
1311c LENIMAX=MAX(LENIMAX,6+3+1)
1312c LENRMAX=MAX(LENRMAX,6+3*3)
1313c IF (NFAC==4) THEN
1314c NPOLY=NPOLY+1
1315c NNS=NNS+3
1316c ELSEIF (NFAC==6) THEN
1317c NPOLY=NPOLY+2
1318c NNS=NNS+6
1319c ENDIF
1320c ENDIF
1321c IF (NFAC==4) THEN
1322c NNP=NNP+1
1323c ELSEIF (NFAC==6) THEN
1324c NNP=NNP+2
1325c ENDIF
1326c ELSEIF (ITY==2) THEN
1327cC Face brique appuyee sur surface
1328c IF (NFAC==4) THEN
1329c NPOLY=NPOLY+1
1330c NNS=NNS+3
1331c NNP=NNP+1
1332c ELSEIF (NFAC==6) THEN
1333c NPOLY=NPOLY+2
1334c NNS=NNS+6
1335c NNP=NNP+2
1336c ENDIF
1337c ELSEIF (ITY==3) THEN
1338cC Face interne brique/polyhedres
1339c PTR_CUR => FIRST
1340c DO K=1,NPOLY_OLD
1341c ITY=PTR_CUR%IPOLY(1)
1342c IF (ITY==1) THEN
1343c IEL=PTR_CUR%IPOLY(3)
1344c IF (-TAGELA(IEL)==I) NNP=NNP+1
1345c ENDIF
1346c PTR_CUR => PTR_CUR%PTR
1347c ENDDO
1348c ENDIF
1349c ENDDO
1350c ITAGBA(I)=1
1351c NPHMAX=MAX(NPHMAX,NNP)
1352cC
1353c II=TBA(1,I)
1354c NALL=1
1355c IF (NFAC==4) THEN
1356c DO J=1,4
1357c JJ=IXS(1+2*(J-1)+1,II)
1358c NALL=NALL*ITAGN(JJ)
1359c ENDDO
1360c ELSEIF (NFAC==6) THEN
1361c DO J=1,8
1362c JJ=IXS(1+J,II)
1363c NALL=NALL*ITAGN(JJ)
1364c ENDDO
1365c ENDIF
1366c IBSA(I)=NALL
1367c ENDDO
1368c DEALLOCATE(ITAGN)
1369c ELSE
1370 ALLOCATE(itagn(nnsa))
1371 npolh=npolh+nba
1372 DO i=1,nba
1373 itagba(i)=0
1374 ENDDO
1375C
1376 DO i=1,nnsa
1377 itagn(i)=0
1378 ENDDO
1379 DO iel=1,nel
1380 n1=fvspmd(ifv)%ELEMSA(1,iel)
1381 n2=fvspmd(ifv)%ELEMSA(2,iel)
1382 n3=fvspmd(ifv)%ELEMSA(3,iel)
1383 IF (n1>0) itagn(n1)=1
1384 IF (n1>0) itagn(n2)=1
1385 IF (n1>0) itagn(n3)=1
1386 ENDDO
1387C
1388 DO i=1,nba
1389 nfac=tba(2,i)
1390 nnp=0
1391 DO j=1,nfac
1392 ity=tfaca(2*(j-1)+1,i)
1393 IF (ity==1) THEN
1394C Face interne brique/brique
1395 nv=tfaca(2*(j-1)+2,i)
1396 IF (itagba(nv)==0) THEN
1397 lenimax=max(lenimax,6+3+1)
1398 lenrmax=max(lenrmax,6+3*3)
1399 IF (nfac==4) THEN
1400 npoly=npoly+1
1401 nns=nns+3
1402 ELSEIF (nfac==6) THEN
1403 npoly=npoly+2
1404 nns=nns+6
1405 ENDIF
1406 ENDIF
1407 IF (nfac==4) THEN
1408 nnp=nnp+1
1409 ELSEIF (nfac==6) THEN
1410 nnp=nnp+2
1411 ENDIF
1412 ELSEIF (ity==2) THEN
1413C Face brique appuyee sur surface
1414 IF (nfac==4) THEN
1415 npoly=npoly+1
1416 nns=nns+3
1417 nnp=nnp+1
1418 ELSEIF (nfac==6) THEN
1419 npoly=npoly+2
1420 nns=nns+6
1421 nnp=nnp+2
1422 ENDIF
1423 ELSEIF (ity==3) THEN
1424C Face interne brique/polyhedres
1425 ptr_cur => first
1426 DO k=1,npoly_old
1427 ity=ptr_cur%IPOLY(1)
1428 IF (ity==1) THEN
1429 iel=ptr_cur%IPOLY(3)
1430 IF (-tagela(iel)==i) nnp=nnp+1
1431 ENDIF
1432 ptr_cur => ptr_cur%PTR
1433 ENDDO
1434 ENDIF
1435 ENDDO
1436 itagba(i)=1
1437 nphmax=max(nphmax,nnp)
1438C
1439 nall=1
1440 IF (nfac==4) THEN
1441 DO j=1,4
1442 jj=fvspmd(ifv)%IXSA(2*(j-1)+1,i)
1443 nall=nall*itagn(jj)
1444 ENDDO
1445 ELSEIF (nfac==6) THEN
1446 DO j=1,8
1447 jj=fvspmd(ifv)%IXSA(j,i)
1448 nall=nall*itagn(jj)
1449 ENDDO
1450 ENDIF
1451 ibsa(i)=nall
1452 ENDDO
1453c ENDIF
1454 ENDIF
1455C
1456 ALLOCATE(ipoly_f(lenimax,npoly), rpoly_f(lenrmax,npoly),
1457 . polh_f(2+nphmax,npolh), ifvnod(nns), volu(npolh),
1458 . ifvnod2(2,nns2), rfvnod2(4,nns2), xns(3,nns),
1459 . xns2(3,nns2))
1460C
1461 npoly=npoly_old
1462 npolh=npolh_old
1463 ptr_cur => first
1464 nns=0
1465 DO i=1,npoly
1466 nn=ptr_cur%IPOLY(2)
1467 DO j=1,nn
1468 jj=ptr_cur%IPOLY(6+j)
1469 IF (jj>0) THEN
1470 nns=nns+1
1471 xns(1,nns)=ptr_cur%RPOLY(4+3*(j-1)+1)
1472 xns(2,nns)=ptr_cur%RPOLY(4+3*(j-1)+2)
1473 xns(3,nns)=ptr_cur%RPOLY(4+3*(j-1)+3)
1474 ENDIF
1475 ENDDO
1476 ptr_cur => ptr_cur%PTR
1477 ENDDO
1478C
1479 nns=0
1480 ptr_cur => first
1481 DO i=1,npoly
1482 nn=ptr_cur%IPOLY(2)
1483 DO j=1,6
1484 ipoly_f(j,i)=ptr_cur%IPOLY(j)
1485 ENDDO
1486 DO j=1,4+3*nn
1487 rpoly_f(j,i)=ptr_cur%RPOLY(j)
1488 ENDDO
1489 DO j=1,nn
1490 jj=ptr_cur%IPOLY(6+j)
1491 IF (jj>0) THEN
1492 nns=nns+1
1493 ipoly_f(6+j,i)=nns
1494 ifvnod(nns)=ptr_cur%IELNOD(j)
1495 ELSE
1496 ipoly_f(6+j,i)=jj
1497 ENDIF
1498 ENDDO
1499 IF (ptr_cur%IPOLY(1)==1) THEN
1500 ipoly_f(4,i)=ipoly_f(5,i)
1501 ipoly_f(5,i)=0
1502 ELSEIF (ptr_cur%IPOLY(1)==2) THEN
1503 nhol=ptr_cur%IPOLY(6+nn+1)
1504 ipoly_f(6+nn+1,i)=nhol
1505 DO j=1,nhol
1506 ipoly_f(6+nn+1+j,i)=ptr_cur%IPOLY(6+nn+1+j)
1507 rpoly_f(4+3*nn+3*(j-1)+1,i)=
1508 . ptr_cur%RPOLY(4+3*nn+3*(j-1)+1)
1509 rpoly_f(4+3*nn+3*(j-1)+2,i)=
1510 . ptr_cur%RPOLY(4+3*nn+3*(j-1)+2)
1511 rpoly_f(4+3*nn+3*(j-1)+3,i)=
1512 . ptr_cur%RPOLY(4+3*nn+3*(j-1)+3)
1513 ENDDO
1514 ENDIF
1515 nnsp=ptr_cur%NNSP
1516 IF (nnsp>0) THEN
1517 DO j=1,nnsp
1518 jj=ptr_cur%NREF(1,j)
1519 ifvnod2(1,jj)=ptr_cur%NREF(2,j)
1520 ifvnod2(2,jj)=ptr_cur%NREF(3,j)
1521 rfvnod2(1,jj)=ptr_cur%AREF(1,j)
1522 rfvnod2(2,jj)=ptr_cur%AREF(2,j)
1523 rfvnod2(3,jj)=ptr_cur%AREF(3,j)
1524 rfvnod2(4,jj)=ptr_cur%AREF(4,j)
1525 ENDDO
1526 ENDIF
1527 ptr_tmp => ptr_cur%PTR
1528 DEALLOCATE(ptr_cur%IPOLY, ptr_cur%RPOLY, ptr_cur%IELNOD)
1529 IF (nnsp>0) DEALLOCATE(ptr_cur%NREF, ptr_cur%AREF)
1530 DEALLOCATE(ptr_cur)
1531 ptr_cur => ptr_tmp
1532 ENDDO
1533C
1534 DO i=1,nns2
1535 n1=ifvnod2(1,i)
1536 n2=ifvnod2(2,i)
1537 idep=0
1538 IF (n1<0) THEN
1539 ii=-n1
1540 IF (ifvnod2(1,ii)/=n2.AND.ifvnod2(2,ii)/=n2) THEN
1541 WRITE(istdo,*) 'PROBLEM DEPENDANT NODE ',i
1542 CALL arret(2)
1543 ENDIF
1544 n1=ifvnod2(1,ii)
1545 n2=ifvnod2(2,ii)
1546 idep=1
1547 ELSEIF (n2<0) THEN
1548 ii=-n2
1549 IF (ifvnod2(1,ii)/=n1.AND.ifvnod2(2,ii)/=n1) THEN
1550 WRITE(istdo,*) 'PROBLEM DEPENDANT NODE ',i
1551 CALL arret(2)
1552 ENDIF
1553 n1=ifvnod2(1,ii)
1554 n2=ifvnod2(2,ii)
1555 idep=1
1556 ENDIF
1557 ifvnod2(1,i)=n1
1558 ifvnod2(2,i)=n2
1559 IF (idep==1) THEN
1560C Recalcul des coordonnees barycentriques du point dependant
1561 ii=1
1562 val=abs(xns(1,n1)-xns(1,n2))
1563 DO j=2,3
1564 IF (abs(xns(j,n1)-xns(j,n2))>val) THEN
1565 ii=j
1566 val=abs(xns(j,n1)-xns(j,n2))
1567 ENDIF
1568 ENDDO
1569 rfvnod2(1,i)=(rfvnod2(ii+1,i)-xns(ii,n2))/
1570 . (xns(ii,n1)-xns(ii,n2))
1571 ENDIF
1572 ENDDO
1573C
1574 ph_cur => phfirst
1575 DO i=1,npolh
1576 nn=ph_cur%POLH(1)
1577 DO j=1,2+nn
1578 polh_f(j,i)=ph_cur%POLH(j)
1579 ENDDO
1580 ph_tmp => ph_cur%PTR
1581 DEALLOCATE(ph_cur%POLH)
1582 DEALLOCATE(ph_cur)
1583 ph_cur => ph_tmp
1584 ENDDO
1585C
1586 IF (nba>0) THEN
1587 DO i=1,nba
1588 itagba(i)=0
1589 ENDDO
1590C
1591 npoly_old=npoly
1592 DO i=1,nba
1593 ii=tba(1,i)
1594 nfac=tba(2,i)
1595 nnp=0
1596 DO j=1,nfac
1597 ity=tfaca(2*(j-1)+1,i)
1598 IF (ity==1) THEN
1599C Face interne brique/brique
1600 nv=tfaca(2*(j-1)+2,i)
1601 IF (itagba(nv)==0) THEN
1602 IF (nfac==4) THEN
1603 npoly=npoly+1
1604 n1=fac4(1,j)
1605 n2=fac4(2,j)
1606 n3=fac4(3,j)
1607 ipoly_f(1,npoly)=2
1608 ipoly_f(2,npoly)=3
1609 ipoly_f(3,npoly)=0
1610 ipoly_f(4,npoly)=0
1611 ipoly_f(5,npoly)=npolh+i
1612 ipoly_f(6,npoly)=npolh+nv
1613 ipoly_f(6+1,npoly)=nns+1
1614 ipoly_f(6+2,npoly)=nns+2
1615 ipoly_f(6+3,npoly)=nns+3
1616 ipoly_f(6+3+1,npoly)=0
1617C
1618c IF (NSPMD == 1) THEN
1619c NN1=IXS(1+N1,II)
1620c NN2=IXS(1+N2,II)
1621c NN3=IXS(1+N3,II)
1622c IFVNOD(NNS+1)=-NN1
1623c IFVNOD(NNS+2)=-NN2
1624c IFVNOD(NNS+3)=-NN3
1625c NNS=NNS+3
1626c X1=X(1,NN1)
1627c Y1=X(2,NN1)
1628c Z1=X(3,NN1)
1629c X2=X(1,NN2)
1630c Y2=X(2,NN2)
1631c Z2=X(3,NN2)
1632c X3=X(1,NN3)
1633c Y3=X(2,NN3)
1634c Z3=X(3,NN3)
1635c ELSE
1636 nn1=fvspmd(ifv)%IXSA(n1,i)
1637 nn2=fvspmd(ifv)%IXSA(n2,i)
1638 nn3=fvspmd(ifv)%IXSA(n3,i)
1639 ifvnod(nns+1)=-nn1
1640 ifvnod(nns+2)=-nn2
1641 ifvnod(nns+3)=-nn3
1642 nns=nns+3
1643 x1=xxxsa(1,nn1)
1644 y1=xxxsa(2,nn1)
1645 z1=xxxsa(3,nn1)
1646 x2=xxxsa(1,nn2)
1647 y2=xxxsa(2,nn2)
1648 z2=xxxsa(3,nn2)
1649 x3=xxxsa(1,nn3)
1650 y3=xxxsa(2,nn3)
1651 z3=xxxsa(3,nn3)
1652c ENDIF
1653 x12=x2-x1
1654 y12=y2-y1
1655 z12=z2-z1
1656 x13=x3-x1
1657 y13=y3-y1
1658 z13=z3-z1
1659 nrx=y12*z13-z12*y13
1660 nry=z12*x13-x12*z13
1661 nrz=x12*y13-y12*x13
1662 area2=sqrt(nrx**2+nry**2+nrz**2)
1663 rpoly_f(2,npoly)=nrx/area2
1664 rpoly_f(3,npoly)=nry/area2
1665 rpoly_f(4,npoly)=nrz/area2
1666 rpoly_f(4+1,npoly)=x1
1667 rpoly_f(4+2,npoly)=y1
1668 rpoly_f(4+3,npoly)=z1
1669 rpoly_f(4+4,npoly)=x2
1670 rpoly_f(4+5,npoly)=y2
1671 rpoly_f(4+6,npoly)=z2
1672 rpoly_f(4+7,npoly)=x3
1673 rpoly_f(4+8,npoly)=y3
1674 rpoly_f(4+9,npoly)=z3
1675C
1676 nnp=nnp+1
1677 polh_f(2+nnp,npolh+i)=npoly
1678 ELSEIF (nfac==6) THEN
1679 n1=fac(1,j)
1680 n2=fac(2,j)
1681 n3=fac(3,j)
1682 n4=fac(4,j)
1683c IF (NSPMD == 1) THEN
1684c NN1=IXS(1+N1,II)
1685c NN2=IXS(1+N2,II)
1686c NN3=IXS(1+N3,II)
1687c NN4=IXS(1+N4,II)
1688c X1=X(1,NN1)
1689c Y1=X(2,NN1)
1690c Z1=X(3,NN1)
1691c X2=X(1,NN2)
1692c Y2=X(2,NN2)
1693c Z2=X(3,NN2)
1694c X3=X(1,NN3)
1695c Y3=X(2,NN3)
1696c Z3=X(3,NN3)
1697c X4=X(1,NN4)
1698c Y4=X(2,NN4)
1699c Z4=X(3,NN4)
1700c ELSE
1701 nn1=fvspmd(ifv)%IXSA(n1,i)
1702 nn2=fvspmd(ifv)%IXSA(n2,i)
1703 nn3=fvspmd(ifv)%IXSA(n3,i)
1704 nn4=fvspmd(ifv)%IXSA(n4,i)
1705 x1=xxxsa(1,nn1)
1706 y1=xxxsa(2,nn1)
1707 z1=xxxsa(3,nn1)
1708 x2=xxxsa(1,nn2)
1709 y2=xxxsa(2,nn2)
1710 z2=xxxsa(3,nn2)
1711 x3=xxxsa(1,nn3)
1712 y3=xxxsa(2,nn3)
1713 z3=xxxsa(3,nn3)
1714 x4=xxxsa(1,nn4)
1715 y4=xxxsa(2,nn4)
1716 z4=xxxsa(3,nn4)
1717c ENDIF
1718C
1719 npoly=npoly+1
1720 ipoly_f(1,npoly)=2
1721 ipoly_f(2,npoly)=3
1722 ipoly_f(3,npoly)=0
1723 ipoly_f(4,npoly)=0
1724 ipoly_f(5,npoly)=npolh+i
1725 ipoly_f(6,npoly)=npolh+nv
1726 ipoly_f(6+1,npoly)=nns+1
1727 ipoly_f(6+2,npoly)=nns+2
1728 ipoly_f(6+3,npoly)=nns+3
1729 ipoly_f(6+3+1,npoly)=0
1730 ifvnod(nns+1)=-nn1
1731 ifvnod(nns+2)=-nn2
1732 ifvnod(nns+3)=-nn3
1733 nns=nns+3
1734 x12=x2-x1
1735 y12=y2-y1
1736 z12=z2-z1
1737 x13=x3-x1
1738 y13=y3-y1
1739 z13=z3-z1
1740 nrx=y12*z13-z12*y13
1741 nry=z12*x13-x12*z13
1742 nrz=x12*y13-y12*x13
1743 area2=sqrt(nrx**2+nry**2+nrz**2)
1744 rpoly_f(2,npoly)=nrx/area2
1745 rpoly_f(3,npoly)=nry/area2
1746 rpoly_f(4,npoly)=nrz/area2
1747 rpoly_f(4+1,npoly)=x1
1748 rpoly_f(4+2,npoly)=y1
1749 rpoly_f(4+3,npoly)=z1
1750 rpoly_f(4+4,npoly)=x2
1751 rpoly_f(4+5,npoly)=y2
1752 rpoly_f(4+6,npoly)=z2
1753 rpoly_f(4+7,npoly)=x3
1754 rpoly_f(4+8,npoly)=y3
1755 rpoly_f(4+9,npoly)=z3
1756C
1757 nnp=nnp+1
1758 polh_f(2+nnp,npolh+i)=npoly
1759C
1760 npoly=npoly+1
1761 ipoly_f(1,npoly)=2
1762 ipoly_f(2,npoly)=3
1763 ipoly_f(3,npoly)=0
1764 ipoly_f(4,npoly)=0
1765 ipoly_f(5,npoly)=npolh+i
1766 ipoly_f(6,npoly)=npolh+nv
1767 ipoly_f(6+1,npoly)=nns+1
1768 ipoly_f(6+2,npoly)=nns+2
1769 ipoly_f(6+3,npoly)=nns+3
1770 ipoly_f(6+3+1,npoly)=0
1771 ifvnod(nns+1)=-nn1
1772 ifvnod(nns+2)=-nn3
1773 ifvnod(nns+3)=-nn4
1774 nns=nns+3
1775 x13=x3-x1
1776 y13=y3-y1
1777 z13=z3-z1
1778 x14=x4-x1
1779 y14=y4-y1
1780 z14=z4-z1
1781 nrx=y13*z14-z13*y14
1782 nry=z13*x14-x13*z14
1783 nrz=x13*y14-y13*x14
1784 area2=sqrt(nrx**2+nry**2+nrz**2)
1785 rpoly_f(2,npoly)=nrx/area2
1786 rpoly_f(3,npoly)=nry/area2
1787 rpoly_f(4,npoly)=nrz/area2
1788 rpoly_f(4+1,npoly)=x1
1789 rpoly_f(4+2,npoly)=y1
1790 rpoly_f(4+3,npoly)=z1
1791 rpoly_f(4+4,npoly)=x3
1792 rpoly_f(4+5,npoly)=y3
1793 rpoly_f(4+6,npoly)=z3
1794 rpoly_f(4+7,npoly)=x4
1795 rpoly_f(4+8,npoly)=y4
1796 rpoly_f(4+9,npoly)=z4
1797C
1798 nnp=nnp+1
1799 polh_f(2+nnp,npolh+i)=npoly
1800 ENDIF
1801 ELSE
1802 DO k=1,polh_f(1,npolh+nv)
1803 kk=polh_f(2+k,npolh+nv)
1804 IF (ipoly_f(1,kk)==2.AND.
1805 . ipoly_f(6,kk)==npolh+i) THEN
1806 nnp=nnp+1
1807 polh_f(2+nnp,npolh+i)=kk
1808 ENDIF
1809 ENDDO
1810 ENDIF
1811 ELSEIF (ity==2) THEN
1812C Face brique appuyee sur surface (traitee plus loin)
1813 ELSEIF (ity==3) THEN
1814C Face interne brique/polyhedres
1815 DO k=1,npoly_old
1816 ity=ipoly_f(1,k)
1817 IF (ity==1) THEN
1818 iel=ipoly_f(3,k)
1819 IF (-tagela(iel)==i) THEN
1820 nnp=nnp+1
1821 polh_f(2+nnp,npolh+i)=k
1822 ipoly_f(1,k)=2
1823 ipoly_f(3,k)=0
1824 ip=ipoly_f(4,k)
1825 ipoly_f(4,k)=0
1826 ipoly_f(5,k)=ip
1827 ipoly_f(6,k)=npolh+i
1828 ENDIF
1829 ENDIF
1830 ENDDO
1831 ENDIF
1832 ENDDO
1833 polh_f(1,npolh+i)=nnp
1834 polh_f(2,npolh+i)=-i
1835 itagba(i)=1
1836 ENDDO
1837C
1838 npolh=npolh+nba
1839C
1840 DO i=1,npoly_old
1841 IF (ipoly_f(1,i)==1) THEN
1842 iel=ipoly_f(3,i)
1843 IF (tagela(iel)>0) ipoly_f(3,i)=tagela(iel)
1844 ENDIF
1845 ENDDO
1846C
1847 DO iel=1,nel
1848 IF (tagels(iel)>0) THEN
1849 npoly=npoly+1
1850 ipoly_f(1,npoly)=1
1851 ipoly_f(2,npoly)=3
1852 ipoly_f(3,npoly)=iel
1853 ipoly_f(4,npoly)=npolh_old+tagels(iel)
1854 ipoly_f(5,npoly)=0
1855 ipoly_f(6,npoly)=0
1856 ipoly_f(7,npoly)=nns+1
1857 ipoly_f(8,npoly)=nns+2
1858 ipoly_f(9,npoly)=nns+3
1859c IF (NSPMD == 1) THEN
1860c N1=ELEM(1,IEL)
1861c N2=ELEM(2,IEL)
1862c N3=ELEM(3,IEL)
1863c NN1=IBUF(N1)
1864c NN2=IBUF(N2)
1865c NN3=IBUF(N3)
1866c IFVNOD(NNS+1)=-NN1
1867c IFVNOD(NNS+2)=-NN2
1868c IFVNOD(NNS+3)=-NN3
1869c NNS=NNS+3
1870c RPOLY_F(1,NPOLY)=ELAREA(IEL)
1871c RPOLY_F(2,NPOLY)=NORM(1,IEL)
1872c RPOLY_F(3,NPOLY)=NORM(2,IEL)
1873c RPOLY_F(4,NPOLY)=NORM(3,IEL)
1874c X1=X(1,NN1)
1875c Y1=X(2,NN1)
1876c Z1=X(3,NN1)
1877c X2=X(1,NN2)
1878c Y2=X(2,NN2)
1879c Z2=X(3,NN2)
1880c X3=X(1,NN3)
1881c Y3=X(2,NN3)
1882c Z3=X(3,NN3)
1883c ELSE
1884 nn1=fvspmd(ifv)%ELEMSA(1,iel)
1885 nn2=fvspmd(ifv)%ELEMSA(2,iel)
1886 nn3=fvspmd(ifv)%ELEMSA(3,iel)
1887 ifvnod(nns+1)=-nn1
1888 ifvnod(nns+2)=-nn2
1889 ifvnod(nns+3)=-nn3
1890 nns=nns+3
1891 rpoly_f(1,npoly)=elarea(iel)
1892 rpoly_f(2,npoly)=norm(1,iel)
1893 rpoly_f(3,npoly)=norm(2,iel)
1894 rpoly_f(4,npoly)=norm(3,iel)
1895 x1=xxxsa(1,nn1)
1896 y1=xxxsa(2,nn1)
1897 z1=xxxsa(3,nn1)
1898 x2=xxxsa(1,nn2)
1899 y2=xxxsa(2,nn2)
1900 z2=xxxsa(3,nn2)
1901 x3=xxxsa(1,nn3)
1902 y3=xxxsa(2,nn3)
1903 z3=xxxsa(3,nn3)
1904c ENDIF
1905 rpoly_f(5,npoly)=x1
1906 rpoly_f(6,npoly)=y1
1907 rpoly_f(7,npoly)=z1
1908 rpoly_f(8,npoly)=x2
1909 rpoly_f(9,npoly)=y2
1910 rpoly_f(10,npoly)=z2
1911 rpoly_f(11,npoly)=x3
1912 rpoly_f(12,npoly)=y3
1913 rpoly_f(13,npoly)=z3
1914C
1915 nnp=polh_f(1,npolh_old+tagels(iel))
1916 nnp=nnp+1
1917 polh_f(1,npolh_old+tagels(iel))=nnp
1918 polh_f(2+nnp,npolh_old+tagels(iel))=npoly
1919 ENDIF
1920 ENDDO
1921 ENDIF
1922C---------------------------------------------------
1923C Surface des polygones
1924C---------------------------------------------------
1925 DO i=1,npoly
1926 ity=ipoly_f(1,i)
1927 nn=ipoly_f(2,i)
1928 nhol=0
1929 IF (ity==2) nhol=ipoly_f(6+nn+1,i)
1930 area=zero
1931 nx=rpoly_f(2,i)
1932 ny=rpoly_f(3,i)
1933 nz=rpoly_f(4,i)
1934 IF (nhol==0) THEN
1935 x1=rpoly_f(5,i)
1936 y1=rpoly_f(6,i)
1937 z1=rpoly_f(7,i)
1938 DO j=1,nn-2
1939 jj=j+1
1940 jjj=jj+1
1941 x2=rpoly_f(4+3*(jj-1)+1,i)
1942 y2=rpoly_f(4+3*(jj-1)+2,i)
1943 z2=rpoly_f(4+3*(jj-1)+3,i)
1944 x3=rpoly_f(4+3*(jjj-1)+1,i)
1945 y3=rpoly_f(4+3*(jjj-1)+2,i)
1946 z3=rpoly_f(4+3*(jjj-1)+3,i)
1947 x12=x2-x1
1948 y12=y2-y1
1949 z12=z2-z1
1950 x13=x3-x1
1951 y13=y3-y1
1952 z13=z3-z1
1953 nnx=y12*z13-z12*y13
1954 nny=z12*x13-x12*z13
1955 nnz=x12*y13-y12*x13
1956 area=area+(nnx*nx+nny*ny+nnz*nz)
1957 ENDDO
1958 ELSE
1959 ALLOCATE(adr(nhol))
1960 DO j=1,nhol
1961 adr(j)=ipoly_f(6+nn+1+j,i)
1962 ENDDO
1963 adr(nhol+1)=nn
1964 x1=rpoly_f(5,i)
1965 y1=rpoly_f(6,i)
1966 z1=rpoly_f(7,i)
1967 DO j=1,adr(1)-2
1968 jj=j+1
1969 jjj=jj+1
1970 x2=rpoly_f(4+3*(jj-1)+1,i)
1971 y2=rpoly_f(4+3*(jj-1)+2,i)
1972 z2=rpoly_f(4+3*(jj-1)+3,i)
1973 x3=rpoly_f(4+3*(jjj-1)+1,i)
1974 y3=rpoly_f(4+3*(jjj-1)+2,i)
1975 z3=rpoly_f(4+3*(jjj-1)+3,i)
1976 x12=x2-x1
1977 y12=y2-y1
1978 z12=z2-z1
1979 x13=x3-x1
1980 y13=y3-y1
1981 z13=z3-z1
1982 nnx=y12*z13-z12*y13
1983 nny=z12*x13-x12*z13
1984 nnz=x12*y13-y12*x13
1985 area=area+(nnx*nx+nny*ny+nnz*nz)
1986 ENDDO
1987 area=abs(area)
1988C On retranche la surface des trous
1989 DO j=1,nhol
1990 x1=rpoly_f(4+3*adr(j)+1,i)
1991 y1=rpoly_f(4+3*adr(j)+2,i)
1992 z1=rpoly_f(4+3*adr(j)+3,i)
1993 area2=zero
1994 DO k=adr(j)+1,adr(j+1)-2
1995 kk=k+1
1996 kkk=kk+1
1997 x2=rpoly_f(4+3*(kk-1)+1,i)
1998 y2=rpoly_f(4+3*(kk-1)+2,i)
1999 z2=rpoly_f(4+3*(kk-1)+3,i)
2000 x3=rpoly_f(4+3*(kkk-1)+1,i)
2001 y3=rpoly_f(4+3*(kkk-1)+2,i)
2002 z3=rpoly_f(4+3*(kkk-1)+3,i)
2003 x12=x2-x1
2004 y12=y2-y1
2005 z12=z2-z1
2006 x13=x3-x1
2007 y13=y3-y1
2008 z13=z3-z1
2009 nnx=y12*z13-z12*y13
2010 nny=z12*x13-x12*z13
2011 nnz=x12*y13-y12*x13
2012 area2=area2+(nnx*nx+nny*ny+nnz*nz)
2013 ENDDO
2014 area=area-abs(area2)
2015 ENDDO
2016 DEALLOCATE(adr)
2017 ENDIF
2018 rpoly_f(1,i)=half*abs(area)
2019 ENDDO
2020C---------------------------------------------------
2021C Volume des polyhedres
2022C---------------------------------------------------
2023 DO i=1,npolh
2024 volu(i)=zero
2025 DO j=1,polh_f(1,i)
2026 jj=polh_f(2+j,i)
2027 area=rpoly_f(1,jj)
2028 ity=ipoly_f(1,jj)
2029 IF (ity==1) THEN
2030 nx=rpoly_f(2,jj)
2031 ny=rpoly_f(3,jj)
2032 nz=rpoly_f(4,jj)
2033 ELSEIF (ity==2) THEN
2034 IF (ipoly_f(5,jj)==i) THEN
2035 nx=rpoly_f(2,jj)
2036 ny=rpoly_f(3,jj)
2037 nz=rpoly_f(4,jj)
2038 ELSEIF (ipoly_f(6,jj)==i) THEN
2039 nx=-rpoly_f(2,jj)
2040 ny=-rpoly_f(3,jj)
2041 nz=-rpoly_f(4,jj)
2042 ENDIF
2043 ENDIF
2044 x1=rpoly_f(5,jj)
2045 y1=rpoly_f(6,jj)
2046 z1=rpoly_f(7,jj)
2047 volu(i)=volu(i)+third*area*(x1*nx+y1*ny+z1*nz)
2048 ENDDO
2049 ENDDO
2050C---------------------------------------------------
2051C Elimination des segments de longueur nulle dans les polygones
2052C---------------------------------------------------
2053 nns_old=nns
2054 ALLOCATE(ifvnod_old(nns_old), redir(nns_old))
2055 DO i=1,nns_old
2056 ifvnod_old(i)=ifvnod(i)
2057 ENDDO
2058 nns_old=0
2059 nns=0
2060C
2061 tole=rvolu(50)
2062 DO i=1,npoly
2063 nnp_old=ipoly_f(2,i)
2064C
2065 lmax2=zero
2066 x0=rpoly_f(5,i)
2067 y0=rpoly_f(6,i)
2068 z0=rpoly_f(7,i)
2069 DO j=2,nnp_old
2070 x1=rpoly_f(4+3*(j-1)+1,i)
2071 y1=rpoly_f(4+3*(j-1)+2,i)
2072 z1=rpoly_f(4+3*(j-1)+3,i)
2073 lmax2=max(lmax2,(x1-x0)**2+(y1-y0)**2+(z1-z0)**2)
2074 x0=x1
2075 y0=y1
2076 z0=z1
2077 ENDDO
2078 x1=rpoly_f(5,i)
2079 y1=rpoly_f(6,i)
2080 z1=rpoly_f(7,i)
2081 lmax2=max(lmax2,(x1-x0)**2+(y1-y0)**2+(z1-z0)**2)
2082 tole2=tole**2*lmax2
2083C
2084 nhol=0
2085 IF (ipoly_f(1,i)==2) nhol=ipoly_f(6+nnp_old+1,i)
2086 ALLOCATE(ipoly_old(nnp_old), rpoly_old(3*nnp_old),
2087 . adr_old(nhol+2), adr(nhol+2))
2088 DO j=1,nnp_old
2089 ipoly_old(j)=ipoly_f(6+j,i)
2090 ENDDO
2091 DO j=1,3*nnp_old
2092 rpoly_old(j)=rpoly_f(4+j,i)
2093 ENDDO
2094 nnp=0
2095 IF (nhol==0) THEN
2096 x0=rpoly_f(5,i)
2097 y0=rpoly_f(6,i)
2098 z0=rpoly_f(7,i)
2099 IF (ipoly_old(1)>0) THEN
2100 nns_old=nns_old+1
2101 nns=nns+1
2102 redir(nns_old)=nns
2103 ipoly_f(7,i)=nns
2104 ifvnod(nns)=ifvnod_old(nns_old)
2105 ELSE
2106 ipoly_f(7,i)=ipoly_old(1)
2107 ENDIF
2108 nnp=nnp+1
2109 j0=1
2110 nns1=nns
2111 DO j=2,nnp_old
2112 IF (ipoly_old(j)>0) nns_old=nns_old+1
2113 x1=rpoly_old(3*(j-1)+1)
2114 y1=rpoly_old(3*(j-1)+2)
2115 z1=rpoly_old(3*(j-1)+3)
2116 dd=(x1-x0)**2+(y1-y0)**2+(z1-z0)**2
2117 IF (dd>tole2) THEN
2118 nnp=nnp+1
2119 IF (ipoly_old(j)>0) THEN
2120 nns=nns+1
2121 ifvnod(nns)=ifvnod_old(nns_old)
2122 rpoly_f(4+3*(nnp-1)+1,i)=x1
2123 rpoly_f(4+3*(nnp-1)+2,i)=y1
2124 rpoly_f(4+3*(nnp-1)+3,i)=z1
2125 ipoly_f(6+nnp,i)=nns
2126 ELSE
2127 rpoly_f(4+3*(nnp-1)+1,i)=x1
2128 rpoly_f(4+3*(nnp-1)+2,i)=y1
2129 rpoly_f(4+3*(nnp-1)+3,i)=z1
2130 ipoly_f(6+nnp,i)=ipoly_old(j)
2131 ENDIF
2132 x0=x1
2133 y0=y1
2134 z0=z1
2135 ELSEIF (ipoly_old(j)>0.AND.
2136 . ipoly_old(j0)<0) THEN
2137 nns=nns+1
2138 ifvnod(nns)=ifvnod_old(nns_old)
2139 rpoly_f(4+3*(nnp-1)+1,i)=x1
2140 rpoly_f(4+3*(nnp-1)+2,i)=y1
2141 rpoly_f(4+3*(nnp-1)+3,i)=z1
2142 ipoly_f(6+nnp,i)=nns
2143 ENDIF
2144 IF (ipoly_old(j)>0) redir(nns_old)=nns
2145 j0=j
2146 ENDDO
2147 x1=rpoly_f(5,i)
2148 y1=rpoly_f(6,i)
2149 z1=rpoly_f(7,i)
2150 dd=(x1-x0)**2+(y1-y0)**2+(z1-z0)**2
2151 IF (dd<=tole2.AND.ipoly_old(1)>0) THEN
2152 redir(nns_old)=nns1
2153 nns=nns-1
2154 nnp=nnp-1
2155 ELSEIF (dd<=tole2.AND.ipoly_old(1)<0) THEN
2156 nnp=nnp-1
2157 rpoly_f(5,i)=x0
2158 rpoly_f(6,i)=y0
2159 rpoly_f(7,i)=z0
2160 ipoly_f(7,i)=nns
2161 ENDIF
2162 ipoly_f(6+nnp+1,i)=0
2163 ELSE
2164 adr_old(1)=0
2165 adr(1)=0
2166 DO j=1,nhol
2167 adr_old(j+1)=ipoly_f(6+nnp_old+1+j,i)
2168 ENDDO
2169 adr_old(nhol+2)=nnp_old
2170 DO j=1,nhol+1
2171 x0=rpoly_f(4+3*adr(j)+1,i)
2172 y0=rpoly_f(4+3*adr(j)+2,i)
2173 z0=rpoly_f(4+3*adr(j)+3,i)
2174 IF (ipoly_old(adr_old(j)+1)>0) THEN
2175 nns_old=nns_old+1
2176 nns=nns+1
2177 redir(nns_old)=nns
2178 ipoly_f(6+adr(j)+1,i)=nns
2179 ifvnod(nns)=ifvnod_old(nns_old)
2180 ELSE
2181 ipoly_f(6+adr(j)+1,i)=ipoly_old(adr_old(j)+1)
2182 ENDIF
2183 nnp=nnp+1
2184 k0=1
2185 nns1=nns
2186 DO k=adr_old(j)+2,adr_old(j+1)
2187 nns_old=nns_old+1
2188 x1=rpoly_old(3*(k-1)+1)
2189 y1=rpoly_old(3*(k-1)+2)
2190 z1=rpoly_old(3*(k-1)+3)
2191 dd=(x1-x0)**2+(y1-y0)**2+(z1-z0)**2
2192 IF (dd>tole2) THEN
2193 nnp=nnp+1
2194 IF (ipoly_old(k)>0) THEN
2195 nns=nns+1
2196 ifvnod(nns)=ifvnod_old(nns_old)
2197 rpoly_f(4+3*(nnp-1)+1,i)=x1
2198 rpoly_f(4+3*(nnp-1)+2,i)=y1
2199 rpoly_f(4+3*(nnp-1)+3,i)=z1
2200 ipoly_f(6+nnp,i)=nns
2201 ELSE
2202 rpoly_f(4+3*(nnp-1)+1,i)=x1
2203 rpoly_f(4+3*(nnp-1)+2,i)=y1
2204 rpoly_f(4+3*(nnp-1)+3,i)=z1
2205 ipoly_f(6+nnp,i)=ipoly_old(k)
2206 ENDIF
2207 x0=x1
2208 y0=y1
2209 z0=z1
2210 ELSEIF (ipoly_old(k)>0.AND.
2211 . ipoly_old(k0)<0) THEN
2212 nns=nns+1
2213 ifvnod(nns)=ifvnod_old(nns_old)
2214 rpoly_f(4+3*(nnp-1)+1,i)=x1
2215 rpoly_f(4+3*(nnp-1)+2,i)=y1
2216 rpoly_f(4+3*(nnp-1)+3,i)=z1
2217 ipoly_f(6+nnp,i)=nns
2218 ENDIF
2219 IF (ipoly_old(k)>0) redir(nns_old)=nns
2220 k0=k
2221 ENDDO
2222 x1=rpoly_f(4+3*(adr(j)-1)+1,i)
2223 y1=rpoly_f(4+3*(adr(j)-1)+2,i)
2224 z1=rpoly_f(4+3*(adr(j)-1)+3,i)
2225 dd=(x1-x0)**2+(y1-y0)**2+(z1-z0)**2
2226 IF (dd<=tole2.AND.ipoly_old(adr_old(j)+1)>0) THEN
2227 redir(nns_old)=nns1
2228 nns=nns-1
2229 nnp=nnp-1
2230 ELSEIF (dd<=tole2.AND.
2231 . ipoly_old(adr_old(j)+1)<0) THEN
2232 nnp=nnp-1
2233 rpoly_f(4+3*(adr(j)-1)+1,i)=x0
2234 rpoly_f(4+3*(adr(j)-1)+2,i)=y0
2235 rpoly_f(4+3*(adr(j)-1)+3,i)=z0
2236 ipoly_f(6+adr(j)+1,i)=nns
2237 ENDIF
2238 adr(j+1)=nnp
2239 ENDDO
2240 ipoly_f(6+nnp+1,i)=nhol
2241 DO j=1,nhol
2242 ipoly_f(6+nnp+1+j,i)=adr(j+1)
2243 rpoly_f(4+3*nnp+3*(j-1)+1,i)=
2244 . rpoly_f(4+3*nnp_old+3*(j-1)+1,i)
2245 rpoly_f(4+3*nnp+3*(j-1)+2,i)=
2246 . rpoly_f(4+3*nnp_old+3*(j-1)+2,i)
2247 rpoly_f(4+3*nnp+3*(j-1)+3,i)=
2248 . rpoly_f(4+3*nnp_old+3*(j-1)+3,i)
2249 ENDDO
2250 ENDIF
2251 ipoly_f(2,i)=nnp
2252C
2253 IF (nnp<nnp_old) THEN
2254C Nouvelle aire du polygone
2255 area=zero
2256 nx=rpoly_f(2,i)
2257 ny=rpoly_f(3,i)
2258 nz=rpoly_f(4,i)
2259 IF (nhol==0) THEN
2260 x1=rpoly_f(5,i)
2261 y1=rpoly_f(6,i)
2262 z1=rpoly_f(7,i)
2263 DO j=1,ipoly_f(2,i)-2
2264 jj=j+1
2265 jjj=jj+1
2266 x2=rpoly_f(4+3*(jj-1)+1,i)
2267 y2=rpoly_f(4+3*(jj-1)+2,i)
2268 z2=rpoly_f(4+3*(jj-1)+3,i)
2269 x3=rpoly_f(4+3*(jjj-1)+1,i)
2270 y3=rpoly_f(4+3*(jjj-1)+2,i)
2271 z3=rpoly_f(4+3*(jjj-1)+3,i)
2272 x12=x2-x1
2273 y12=y2-y1
2274 z12=z2-z1
2275 x13=x3-x1
2276 y13=y3-y1
2277 z13=z3-z1
2278 nnx=y12*z13-z12*y13
2279 nny=z12*x13-x12*z13
2280 nnz=x12*y13-y12*x13
2281 area=area+(nnx*nx+nny*ny+nnz*nz)
2282 ENDDO
2283 ELSE
2284 x1=rpoly_f(5,i)
2285 y1=rpoly_f(6,i)
2286 z1=rpoly_f(7,i)
2287 DO j=1,adr(1)-2
2288 jj=j+1
2289 jjj=jj+1
2290 x2=rpoly_f(4+3*(jj-1)+1,i)
2291 y2=rpoly_f(4+3*(jj-1)+2,i)
2292 z2=rpoly_f(4+3*(jj-1)+3,i)
2293 x3=rpoly_f(4+3*(jjj-1)+1,i)
2294 y3=rpoly_f(4+3*(jjj-1)+2,i)
2295 z3=rpoly_f(4+3*(jjj-1)+3,i)
2296 x12=x2-x1
2297 y12=y2-y1
2298 z12=z2-z1
2299 x13=x3-x1
2300 y13=y3-y1
2301 z13=z3-z1
2302 nnx=y12*z13-z12*y13
2303 nny=z12*x13-x12*z13
2304 nnz=x12*y13-y12*x13
2305 area=area+(nnx*nx+nny*ny+nnz*nz)
2306 ENDDO
2307 ENDIF
2308C
2309 DO j=1,nhol
2310 x1=rpoly_f(4+3*adr(j+1)+1,i)
2311 y1=rpoly_f(4+3*adr(j+1)+2,i)
2312 z1=rpoly_f(4+3*adr(j+1)+3,i)
2313 DO k=adr(j+1)+1,adr(j+2)
2314 kk=k+1
2315 kkk=kk+1
2316 x2=rpoly_f(4+3*(kk-1)+1,i)
2317 y2=rpoly_f(4+3*(kk-1)+2,i)
2318 z2=rpoly_f(4+3*(kk-1)+3,i)
2319 x3=rpoly_f(4+3*(kkk-1)+1,i)
2320 y3=rpoly_f(4+3*(kkk-1)+2,i)
2321 z3=rpoly_f(4+3*(kkk-1)+3,i)
2322 x12=x2-x1
2323 y12=y2-y1
2324 z12=z2-z1
2325 x13=x3-x1
2326 y13=y3-y1
2327 z13=z3-z1
2328 nnx=y12*z13-z12*y13
2329 nny=z12*x13-x12*z13
2330 nnz=x12*y13-y12*x13
2331 area=area-(nnx*nx+nny*ny+nnz*nz)
2332 ENDDO
2333 ENDDO
2334 rpoly_f(1,i)=half*abs(area)
2335 ENDIF
2336C
2337 DEALLOCATE(ipoly_old, rpoly_old, adr_old, adr)
2338 ENDDO
2339C
2340C
2341 DO i=1,nns2
2342 i1=ifvnod2(1,i)
2343 i2=ifvnod2(2,i)
2344 ifvnod2(1,i)=redir(i1)
2345 ifvnod2(2,i)=redir(i2)
2346 ENDDO
2347C
2348 DEALLOCATE(ifvnod_old, redir)
2349C---------------------------------------------------
2350C Fusion des polyhedres a volume infinitesimal a leur voisin
2351C---------------------------------------------------
2352 nphmax=2*nphmax
2353 info=0
2354 ALLOCATE(volu_old(npolh), rpoly_f_old(lenrmax,npoly),
2355 . ipoly_f_old(lenimax,npoly))
2356 DO i=1,npolh
2357 volu_old(i)=volu(i)
2358 ENDDO
2359 DO i=1,npoly
2360 DO j=1,lenimax
2361 ipoly_f_old(j,i)=ipoly_f(j,i)
2362 ENDDO
2363 DO j=1,lenrmax
2364 rpoly_f_old(j,i)=rpoly_f(j,i)
2365 ENDDO
2366 ENDDO
2367 400 IF (ALLOCATED(polh_new)) DEALLOCATE(polh_new)
2368 IF (ALLOCATED(imerged)) DEALLOCATE(imerged)
2369 ALLOCATE(polh_new(2+nphmax,npolh), imerged(npolh))
2370C
2371 IF (info==1) THEN
2372 DO i=1,npolh
2373 volu(i)=volu_old(i)
2374 ENDDO
2375 DO i=1,npoly
2376 DO j=1,lenimax
2377 ipoly_f(j,i)=ipoly_f_old(j,i)
2378 ENDDO
2379 DO j=1,lenrmax
2380 rpoly_f(j,i)=rpoly_f_old(j,i)
2381 ENDDO
2382 ENDDO
2383 ENDIF
2384C
2385 DO i=1,npolh
2386 imerged(i)=0
2387 DO j=1,2+polh_f(1,i)
2388 polh_new(j,i)=polh_f(j,i)
2389 ENDDO
2390 ENDDO
2391C
2392 DO i=1,npolh
2393 IF (polh_f(2,i)<0) cycle
2394 IF (volu(i)<zero) THEN
2395 DO j=1,polh_f(1,i)
2396 jj=polh_f(2+j,i)
2397 rpoly_f(1,jj)=-one
2398 ENDDO
2399 volu(i)=zero
2400 ENDIF
2401 ENDDO
2402C
2403C Volume moyen
2404 vm=zero
2405 npa=0
2406 DO i=1,npolh
2407 IF (volu(i)>zero) THEN
2408 vm=vm+volu(i)
2409 npa=npa+1
2410 ENDIF
2411 ENDDO
2412 vm=vm/npa
2413C
2414 rvolu(33)=vm
2415 volumin=vm*rvolu(31)
2416 info=0
2417 DO i=1,npolh
2418 IF (polh_new(2,i)<0) THEN
2419 ii=-polh_new(2,i)
2420C On ne merge pas les briques additionnelles qui ont des noeuds a l'interieur de l'airbag
2421 IF(ibsa(ii)==0) cycle
2422 ENDIF
2423C
2424 IF (volu(i)<=volumin) THEN
2425 areamax=zero
2426 jmax=0
2427 imax=0
2428 DO j=1,polh_new(1,i)
2429 jj=polh_new(2+j,i)
2430 ity=ipoly_f(1,jj)
2431 IF (ity==1) cycle
2432 area=rpoly_f(1,jj)
2433 IF (area>areamax) THEN
2434 IF (ipoly_f(5,jj)==i) THEN
2435 ii=ipoly_f(6,jj)
2436 IF (polh_new(2,ii)<0) THEN
2437 iii=-polh_new(2,ii)
2438 IF (ibsa(iii)==0) cycle
2439 ENDIF
2440C
2441 jmax=j
2442 imax=ii
2443 ELSEIF (ipoly_f(6,jj)==i) THEN
2444 ii=ipoly_f(5,jj)
2445 IF (polh_new(2,ii)<0) THEN
2446 iii=-polh_new(2,ii)
2447 IF (ibsa(iii)==0) cycle
2448 ENDIF
2449C
2450 jmax=j
2451 imax=ii
2452 ENDIF
2453 areamax=area
2454 ENDIF
2455 ENDDO
2456 IF (jmax/=0) THEN
2457 jjmax=polh_new(2+jmax,i)
2458 rpoly_f(1,jjmax)=-one
2459 ELSE
2460 jmax=1
2461 jjmax=polh_new(2+jmax,i)
2462 ity=ipoly_f(1,jjmax)
2463 IF (ity==2) rpoly_f(1,jjmax)=-one
2464C On merge tous les polyhedres de volume nul avec le polyhedre 1
2465 imax=1
2466 ENDIF
2467 IF (imerged(imax)==1) imax=polh_new(2,imax)
2468 np=polh_new(1,imax)
2469 volu(imax)=volu(imax)+volu(i)
2470 volu(i)=-one
2471 imerged(i)=1
2472 DO j=1,polh_new(1,i)
2473 IF (j/=jmax) THEN
2474 np=np+1
2475 IF (np>nphmax) info=1
2476 IF (info==0) THEN
2477 jj=polh_new(2+j,i)
2478 polh_new(2+np,imax)=jj
2479 ity=ipoly_f(1,jj)
2480 IF (ity==2) THEN
2481 IF (ipoly_f(5,jj)==i) THEN
2482 ipoly_f(5,jj)=imax
2483 ELSEIF (ipoly_f(6,jj)==i) THEN
2484 ipoly_f(6,jj)=imax
2485 ENDIF
2486 ENDIF
2487 ELSE
2488 nphmax=max(nphmax,np)
2489 ENDIF
2490 ENDIF
2491 ENDDO
2492 polh_new(2,i)=imax
2493 IF (info==0) polh_new(1,imax)=np
2494 ENDIF
2495 ENDDO
2496 IF (info==1) GOTO 400
2497C
2498 vmin=ep30
2499 DO i=1,npolh
2500 IF (volu(i)<=zero) cycle
2501 IF (volu(i)<vmin) THEN
2502 vmin=volu(i)
2503 imin=i
2504 ENDIF
2505 DO j=1,polh_new(1,i)
2506 jj=polh_new(2+j,i)
2507 IF (ipoly_f(1,jj)==1.OR.rpoly_f(1,jj)<zero) cycle
2508 IF (ipoly_f(5,jj)==ipoly_f(6,jj)) rpoly_f(1,jj)=-one
2509 ENDDO
2510 ENDDO
2511 DEALLOCATE(volu_old, rpoly_f_old, ipoly_f_old, imerged)
2512C---------------------------------------------------
2513C Verifications
2514C---------------------------------------------------
2515 volph=zero
2516 areap=zero
2517 areael=zero
2518 npolhf=0
2519 DO i=1,npolh
2520 IF (volu(i)>zero) THEN
2521 npolhf=npolhf+1
2522 volph=volph+volu(i)
2523 ENDIF
2524 ENDDO
2525 nspoly=0
2526 ncpoly=0
2527 DO i=1,npoly
2528 ity=ipoly_f(1,i)
2529 IF (ity==1.AND.rpoly_f(1,i)>zero) THEN
2530 nspoly=nspoly+1
2531 areap=areap+rpoly_f(1,i)
2532 ELSEIF (ity==2.AND.rpoly_f(1,i)>zero) THEN
2533 ncpoly=ncpoly+1
2534 ENDIF
2535 ENDDO
2536 DO iel=1,nel
2537 areael=areael+elarea(iel)
2538 ENDDO
2539C---------------------------------------------------
2540C Coordonnees elementaires des nouveaux noeuds
2541C---------------------------------------------------
2542 ALLOCATE(fvdata(ifv)%IFVNOD(3,nns+nns2),
2543 . fvdata(ifv)%RFVNOD(2,nns+nns2))
2544 DO i=1,nns+nns2
2545 fvdata(ifv)%IFVNOD(1,i)=0
2546 ENDDO
2547C
2548 nns_old=nns
2549 nns=0
2550 DO i=1,npoly
2551 nnp=ipoly_f(2,i)
2552 DO j=1,nnp
2553 IF (ipoly_f(6+j,i)>0) THEN
2554 nns=nns+1
2555 IF (ifvnod(nns)<0) THEN
2556 fvdata(ifv)%IFVNOD(1,nns)=2
2557 fvdata(ifv)%IFVNOD(2,nns)=-ifvnod(nns)
2558 cycle
2559 ENDIF
2560 fvdata(ifv)%IFVNOD(1,nns)=1
2561 iel=ifvnod(nns)
2562 fvdata(ifv)%IFVNOD(2,nns)=iel
2563 xx=rpoly_f(4+3*(j-1)+1,i)
2564 yy=rpoly_f(4+3*(j-1)+2,i)
2565 zz=rpoly_f(4+3*(j-1)+3,i)
2566C
2567 n1=elema(1,iel)
2568 n2=elema(2,iel)
2569 n3=elema(3,iel)
2570 IF (tagela(iel)>0) THEN
2571 x1=xxx(1,n1)
2572 y1=xxx(2,n1)
2573 z1=xxx(3,n1)
2574 x2=xxx(1,n2)
2575 y2=xxx(2,n2)
2576 z2=xxx(3,n2)
2577 x3=xxx(1,n3)
2578 y3=xxx(2,n3)
2579 z3=xxx(3,n3)
2580 ELSEIF (tagela(iel)<0) THEN
2581 x1=xxxa(1,n1)
2582 y1=xxxa(2,n1)
2583 z1=xxxa(3,n1)
2584 x2=xxxa(1,n2)
2585 y2=xxxa(2,n2)
2586 z2=xxxa(3,n2)
2587 x3=xxxa(1,n3)
2588 y3=xxxa(2,n3)
2589 z3=xxxa(3,n3)
2590 ENDIF
2591C
2592 vpx=xx-x1
2593 vpy=yy-y1
2594 vpz=zz-z1
2595 v1x=x2-x1
2596 v1y=y2-y1
2597 v1z=z2-z1
2598 v2x=x3-x1
2599 v2y=y3-y1
2600 v2z=z3-z1
2601 CALL coorloc(vpx, vpy, vpz, v1x, v1y,
2602 . v1z, v2x, v2y, v2z, ksi,
2603 . eta)
2604C
2605 fvdata(ifv)%RFVNOD(1,nns)=ksi
2606 fvdata(ifv)%RFVNOD(2,nns)=eta
2607 ELSE
2608 jj=-ipoly_f(6+j,i)
2609 fvdata(ifv)%IFVNOD(1,nns_old+jj)=3
2610 fvdata(ifv)%IFVNOD(2,nns_old+jj)=ifvnod2(1,jj)
2611 fvdata(ifv)%IFVNOD(3,nns_old+jj)=ifvnod2(2,jj)
2612 fvdata(ifv)%RFVNOD(1,nns_old+jj)=rfvnod2(1,jj)
2613 ENDIF
2614 ENDDO
2615 ENDDO
2616 DO i=1,nns2
2617 IF (fvdata(ifv)%IFVNOD(1,nns+i)==0) THEN
2618 fvdata(ifv)%IFVNOD(1,nns+i)=3
2619 fvdata(ifv)%IFVNOD(2,nns+i)=1
2620 fvdata(ifv)%IFVNOD(3,nns+i)=2
2621 fvdata(ifv)%RFVNOD(1,nns+i)=one
2622 ENDIF
2623 ENDDO
2624C---------------------------------------------------
2625C Triangulation des polygones
2626C---------------------------------------------------
2627 nntr=0
2628 DO i=1,npoly
2629 nn=ipoly_f(2,i)
2630 nntr=nntr+nn
2631 ENDDO
2632 ALLOCATE(fvdata(ifv)%IFVTRI(6,nntr),
2633 . fvdata(ifv)%IFVPOLY(nntr),
2634 . fvdata(ifv)%IFVTADR(npoly+1))
2635C
2636 nntr=0
2637 npoly_old=npoly
2638 npoly=0
2639 ALLOCATE(redir_poly(npoly_old))
2640 DO i=1,npoly_old
2641 redir_poly(i)=0
2642 ENDDO
2643C
2644 nns=0
2645 DO i=1,npoly_old
2646 IF (rpoly_f(1,i)<=zero) THEN
2647 DO j=1,ipoly_f(2,i)
2648 IF (ipoly_f(6+j,i)>0) nns=nns+1
2649 ENDDO
2650 cycle
2651 ENDIF
2652 npoly=npoly+1
2653 redir_poly(i)=npoly
2654 nnp=ipoly_f(2,i)
2655 nhol=0
2656 IF (ipoly_f(1,i)==2) nhol=ipoly_f(6+nnp+1,i)
2657 ALLOCATE(pnodes(2,nnp), pseg(2,nnp), pholes(2,nhol),
2658 . ptri(3,nnp), redir(nnp))
2659 ptri(1:3,1:nnp)=0
2660C
2661 DO j=1,nnp
2662 IF (ipoly_f(6+j,i)>0) THEN
2663 nns=nns+1
2664 redir(j)=nns
2665 ELSE
2666 jj=-ipoly_f(6+j,i)
2667 redir(j)=nns_old+jj
2668 ENDIF
2669 ENDDO
2670 IF (ipoly_f(1,i)==1) THEN
2671 ipsurf=ipoly_f(3,i)
2672 ic1=0
2673 ic2=0
2674 ELSEIF (ipoly_f(1,i)==2) THEN
2675 ipsurf=0
2676 ic1=ipoly_f(5,i)
2677 ic2=ipoly_f(6,i)
2678 ENDIF
2679C
2680C Coordonnees des sommets dans le plan du polygone
2681 nx=rpoly_f(2,i)
2682 ny=rpoly_f(3,i)
2683 nz=rpoly_f(4,i)
2684C
2685 x0=rpoly_f(5,i)
2686 y0=rpoly_f(6,i)
2687 z0=rpoly_f(7,i)
2688 x1=rpoly_f(8,i)
2689 y1=rpoly_f(9,i)
2690 z1=rpoly_f(10,i)
2691 nrm1=sqrt((x1-x0)**2+(y1-y0)**2+(z1-z0)**2)
2692 vx1=(x1-x0)/nrm1
2693 vy1=(y1-y0)/nrm1
2694 vz1=(z1-z0)/nrm1
2695 vx2=ny*vz1-nz*vy1
2696 vy2=nz*vx1-nx*vz1
2697 vz2=nx*vy1-ny*vx1
2698C
2699 pnodes(1,1)=zero
2700 pnodes(2,1)=zero
2701 IF (nhol==0) THEN
2702 DO j=2,nnp
2703 xx=rpoly_f(4+3*(j-1)+1,i)
2704 yy=rpoly_f(4+3*(j-1)+2,i)
2705 zz=rpoly_f(4+3*(j-1)+3,i)
2706 vx=xx-x0
2707 vy=yy-y0
2708 vz=zz-z0
2709 pnodes(1,j)=vx*vx1+vy*vy1+vz*vz1
2710 pnodes(2,j)=vx*vx2+vy*vy2+vz*vz2
2711 pseg(1,j-1)=j-1
2712 pseg(2,j-1)=j
2713 ENDDO
2714 pseg(1,nnp)=nnp
2715 pseg(2,nnp)=1
2716 nseg=nnp
2717 ELSE
2718 ALLOCATE(adr(nhol+1))
2719 DO j=1,nhol
2720 adr(j)=ipoly_f(6+nnp+1+j,i)
2721 ENDDO
2722 adr(nhol+1)=nnp
2723 nseg=0
2724 DO j=2,adr(1)
2725 xx=rpoly_f(4+3*(j-1)+1,i)
2726 yy=rpoly_f(4+3*(j-1)+2,i)
2727 zz=rpoly_f(4+3*(j-1)+3,i)
2728 vx=xx-x0
2729 vy=yy-y0
2730 vz=zz-z0
2731 pnodes(1,j)=vx*vx1+vy*vy1+vz*vz1
2732 pnodes(2,j)=vx*vx2+vy*vy2+vz*vz2
2733 nseg=nseg+1
2734 pseg(1,nseg)=j-1
2735 pseg(2,nseg)=j
2736 ENDDO
2737 nseg=nseg+1
2738 pseg(1,nseg)=adr(1)
2739 pseg(2,nseg)=1
2740 DO j=1,nhol
2741 xx=rpoly_f(4+3*adr(j)+1,i)
2742 yy=rpoly_f(4+3*adr(j)+2,i)
2743 zz=rpoly_f(4+3*adr(j)+3,i)
2744 vx=xx-x0
2745 vy=yy-y0
2746 vz=zz-z0
2747 pnodes(1,adr(j)+1)=vx*vx1+vy*vy1+vz*vz1
2748 pnodes(2,adr(j)+1)=vx*vx2+vy*vy2+vz*vz2
2749 DO k=adr(j)+2,adr(j+1)
2750 xx=rpoly_f(4+3*(k-1)+1,i)
2751 yy=rpoly_f(4+3*(k-1)+2,i)
2752 zz=rpoly_f(4+3*(k-1)+3,i)
2753 vx=xx-x0
2754 vy=yy-y0
2755 vz=zz-z0
2756 pnodes(1,k)=vx*vx1+vy*vy1+vz*vz1
2757 pnodes(2,k)=vx*vx2+vy*vy2+vz*vz2
2758 nseg=nseg+1
2759 pseg(1,nseg)=k-1
2760 pseg(2,nseg)=k
2761 ENDDO
2762 nseg=nseg+1
2763 pseg(1,nseg)=adr(j+1)
2764 pseg(2,nseg)=adr(j)+1
2765C
2766 xx=rpoly_f(4+3*nnp+3*(j-1)+1,i)
2767 yy=rpoly_f(4+3*nnp+3*(j-1)+2,i)
2768 zz=rpoly_f(4+3*nnp+3*(j-1)+3,i)
2769 vx=xx-x0
2770 vy=yy-y0
2771 vz=zz-z0
2772 pholes(1,j)=vx*vx1+vy*vy1+vz*vz1
2773 pholes(2,j)=vx*vx2+vy*vy2+vz*vz2
2774 ENDDO
2775 ENDIF
2776C
2777 nelp = 0
2778 CALL c_tricall(pnodes, pseg, pholes, ptri, nnp,
2779 . nseg, nhol, nelp )
2780C
2781 fvdata(ifv)%IFVTADR(npoly)=nntr+1
2782 DO j=1,nelp
2783 nntr=nntr+1
2784 n1=ptri(1,j)
2785 n2=ptri(2,j)
2786 n3=ptri(3,j)
2787C Verification de la normale
2788 x1=rpoly_f(4+3*(n1-1)+1,i)
2789 y1=rpoly_f(4+3*(n1-1)+2,i)
2790 z1=rpoly_f(4+3*(n1-1)+3,i)
2791 x2=rpoly_f(4+3*(n2-1)+1,i)
2792 y2=rpoly_f(4+3*(n2-1)+2,i)
2793 z2=rpoly_f(4+3*(n2-1)+3,i)
2794 x3=rpoly_f(4+3*(n3-1)+1,i)
2795 y3=rpoly_f(4+3*(n3-1)+2,i)
2796 z3=rpoly_f(4+3*(n3-1)+3,i)
2797 x12=x2-x1
2798 y12=y2-y1
2799 z12=z2-z1
2800 x13=x3-x1
2801 y13=y3-y1
2802 z13=z3-z1
2803 nrx=y12*z13-z12*y13
2804 nry=z12*x13-x12*z13
2805 nrz=x12*y13-y12*x13
2806 ss=nrx*nx+nry*ny+nrz*nz
2807C
2808 IF (ss>zero) THEN
2809 fvdata(ifv)%IFVTRI(1,nntr)=redir(n1)
2810 fvdata(ifv)%IFVTRI(2,nntr)=redir(n2)
2811 fvdata(ifv)%IFVTRI(3,nntr)=redir(n3)
2812 ELSE
2813 fvdata(ifv)%IFVTRI(1,nntr)=redir(n1)
2814 fvdata(ifv)%IFVTRI(2,nntr)=redir(n3)
2815 fvdata(ifv)%IFVTRI(3,nntr)=redir(n2)
2816 ENDIF
2817 fvdata(ifv)%IFVTRI(4,nntr)=ipsurf
2818 fvdata(ifv)%IFVTRI(5,nntr)=ic1
2819 fvdata(ifv)%IFVTRI(6,nntr)=ic2
2820 fvdata(ifv)%IFVPOLY(nntr)=nntr
2821 ENDDO
2822C
2823 DEALLOCATE(pnodes, pseg, pholes, ptri, redir)
2824 ENDDO
2825 fvdata(ifv)%IFVTADR(npoly+1)=nntr+1
2826C---------------------------------------------------
2827C Structure des polyhedres
2828C---------------------------------------------------
2829 ALLOCATE(fvdata(ifv)%IFVPOLH(2*npoly),
2830 . fvdata(ifv)%IFVPADR(npolh+1),
2831 . fvdata(ifv)%IDPOLH(npolh),
2832 . fvdata(ifv)%IBPOLH(npolh))
2833 nnp=0
2834 npolh_old=npolh
2835 npolh=0
2836 ALLOCATE(redir_polh(npolh_old))
2837 DO i=1,npolh_old
2838 redir_polh(i)=0
2839 ENDDO
2840C
2841 DO i=1,npolh_old
2842 IF (volu(i)<=zero) cycle
2843 npolh=npolh+1
2844 redir_polh(i)=npolh
2845 fvdata(ifv)%IFVPADR(npolh)=nnp+1
2846 DO j=1,polh_new(1,i)
2847 jj=redir_poly(polh_new(2+j,i))
2848 IF (jj==0) cycle
2849 nnp=nnp+1
2850 fvdata(ifv)%IFVPOLH(nnp)=redir_poly(polh_new(2+j,i))
2851 ENDDO
2852C
2853 fvdata(ifv)%IDPOLH(npolh)=npolh
2854C
2855 ii=polh_new(2,i)
2856 IF (ii>=0) ii=0
2857 IF (ii<0.AND.ibsa(-ii)==1) ii=-ii
2858 fvdata(ifv)%IBPOLH(npolh)=ii
2859 ENDDO
2860 fvdata(ifv)%IFVPADR(npolh+1)=nnp+1
2861C
2862 DO i=1,nntr
2863 IF (fvdata(ifv)%IFVTRI(4,i)==0) THEN
2864 ic1=fvdata(ifv)%IFVTRI(5,i)
2865 ic2=fvdata(ifv)%IFVTRI(6,i)
2866 fvdata(ifv)%IFVTRI(5,i)=redir_polh(ic1)
2867 fvdata(ifv)%IFVTRI(6,i)=redir_polh(ic2)
2868 ENDIF
2869 ENDDO
2870C
2871 ivolu(46)=nns+nns2
2872 ivolu(47)=nntr
2873 ivolu(48)=npoly
2874 ivolu(49)=npolh
2875C
2876 fvdata(ifv)%NNS=nns+nns2
2877 fvdata(ifv)%NNTR=nntr
2878 fvdata(ifv)%LENP=fvdata(ifv)%IFVTADR(npoly+1)-1
2879 fvdata(ifv)%NPOLY=npoly
2880 fvdata(ifv)%LENH=fvdata(ifv)%IFVPADR(npolh+1)-1
2881 fvdata(ifv)%NPOLH=npolh
2882C
2883 ALLOCATE(fvdata(ifv)%MPOLH(npolh), fvdata(ifv)%QPOLH(3,npolh),
2884 . fvdata(ifv)%EPOLH(npolh), fvdata(ifv)%PPOLH(npolh),
2885 . fvdata(ifv)%RPOLH(npolh), fvdata(ifv)%GPOLH(npolh),
2886 . fvdata(ifv)%CPAPOLH(npolh), fvdata(ifv)%CPBPOLH(npolh),
2887 . fvdata(ifv)%CPCPOLH(npolh), fvdata(ifv)%RMWPOLH(npolh),
2888 . fvdata(ifv)%VPOLH_INI(npolh), fvdata(ifv)%DTPOLH(npolh),
2889 . fvdata(ifv)%TPOLH(npolh), fvdata(ifv)%CPDPOLH(npolh),
2890 . fvdata(ifv)%CPEPOLH(npolh), fvdata(ifv)%CPFPOLH(npolh))
2891C
2892 DO i=1,npolh_old
2893 ii=redir_polh(i)
2894 IF (ii==0) cycle
2895 fvdata(ifv)%VPOLH_INI(ii)=volu(i)
2896 ENDDO
2897C
2898 DEALLOCATE(ipoly_f, rpoly_f, polh_f, volu, redir_poly, redir_polh,
2899 . polh_new, ifvnod, ifvnod2, rfvnod2, xns, xns2)
2900C---------------------------------------------------
2901C Impressions
2902C---------------------------------------------------
2903 nstr=0
2904 nctr=0
2905 DO i=1,nntr
2906 IF (fvdata(ifv)%IFVTRI(4,i)>0) THEN
2907 nstr=nstr+1
2908 ELSE
2909 nctr=nctr+1
2910 ENDIF
2911 ENDDO
2912C
2913 WRITE(istdo,*)
2914 WRITE(istdo,'(A25,I10,A24)')
2915 .' ** MONITORED VOLUME ID: ',ivolu(1),' - FINITE VOLUME MESH **'
2916 WRITE(istdo,'(A42,I8)')
2917 . ' NUMBER OF SURFACE POLYGONS : ',nspoly
2918 WRITE(istdo,'(A42,I8)')
2919 . ' NUMBER OF SURFACE TRIANGLES : ',nstr
2920 WRITE(istdo,'(A42,I8)')
2921 . ' NUMBER OF COMMUNICATION POLYGONS : ',ncpoly
2922 WRITE(istdo,'(A42,I8)')
2923 . ' NUMBER OF COMMUNICATION TRIANGLES : ',nctr
2924 WRITE(istdo,'(A42,I8)')
2925 . ' NUMBER OF POLYHEDRA (FINITE VOLUMES): ',npolhf
2926 IF (ilvout>=1) WRITE(istdo,'(A29,G16.9,A8,I8,A1)')
2927 . ' MIN. POLYHEDRON VOLUME : ',vmin,' (POLY. ',imin,')'
2928 IF (ilvout>=1) WRITE(istdo,'(A29,G16.9)')
2929 . ' INITIAL MERGING VOLUME : ',volumin
2930 WRITE(istdo,'(A29,G16.9,A17,G16.9,A1)')
2931 .' SUM VOLUME POLYHEDRA : ',volph,' (VOLUME AIRBAG: ',volg,')'
2932 WRITE(istdo,'(A29,G16.9,A17,G16.9,A1)')
2933 .' SUM AREA SURF. POLYGONS: ',areap,
2934 . ' (AREA AIRBAG : ',areael,')'
2935 WRITE(istdo,*)
2936 WRITE(iout,*)
2937 WRITE(iout,'(A25,I10,A24)')
2938 .' ** monitored volume id: ',IVOLU(1),' - finite volume mesh **'
2939 WRITE(IOUT,'(a42,i8)')
2940 . ' number of surface polygons : ',NSPOLY
2941 WRITE(IOUT,'(a42,i8)')
2942 . ' number of communication polygons : ',NCPOLY
2943 WRITE(IOUT,'(a42,i8)')
2944 . ' number of polyhedra(finite volumes): ',NPOLHF
2945 IF (ILVOUT>=1) WRITE(IOUT,'(a29,g16.9,a8,i8,a1)')
2946 . ' min. polyhedron volume : ',VMIN,' (poly. ',IMIN,')'
2947 IF (ILVOUT>=1) WRITE(IOUT,'(a29,g16.9)')
2948 . ' initial merging volume : ',VOLUMIN
2949 WRITE(IOUT,'(a29,g16.9,a17,g16.9,a1)')
2950 .' sum volume polyhedra : ',VOLPH,' (volume airbag: ',VOLG,')'
2951 WRITE(IOUT,'(a29,g16.9,a17,g16.9,a1)')
2952 .' sum area surf. polygons: ',AREAP,
2953 . ' (area airbag : ',AREAEL,')'
2954 WRITE(IOUT,*)
2955C---------------------------------------------------
2956C Anim des volumes finis
2957C---------------------------------------------------
2958 FVDATA(IFV)%NPOLH_ANIM=NPOLH
2959 LENP=FVDATA(IFV)%IFVTADR(NPOLY+1)
2960 LENH=FVDATA(IFV)%IFVPADR(NPOLH+1)
2961 ALLOCATE(FVDATA(IFV)%IFVPOLY_ANIM(LENP),
2962 . FVDATA(IFV)%IFVTADR_ANIM(NPOLY+1),
2963 . FVDATA(IFV)%IFVPOLH_ANIM(LENH),
2964 . FVDATA(IFV)%IFVPADR_ANIM(NPOLH+1),
2965 . FVDATA(IFV)%IFVTRI_ANIM(6,NNTR),
2966 . FVDATA(IFV)%REDIR_ANIM(NNS+NNS2),
2967 . FVDATA(IFV)%NOD_ANIM(3,NNS+NNS2),
2968 . REDIR(NNS+NNS2), ITAGT(NNTR))
2969 DO I=1,LENP
2970 FVDATA(IFV)%IFVPOLY_ANIM(I)=FVDATA(IFV)%IFVPOLY(I)
2971 ENDDO
2972 DO I=1,NPOLY+1
2973 FVDATA(IFV)%IFVTADR_ANIM(I)=FVDATA(IFV)%IFVTADR(I)
2974 ENDDO
2975 DO I=1,LENH
2976 FVDATA(IFV)%IFVPOLH_ANIM(I)=FVDATA(IFV)%IFVPOLH(I)
2977 ENDDO
2978 DO I=1,NPOLH+1
2979 FVDATA(IFV)%IFVPADR_ANIM(I)=FVDATA(IFV)%IFVPADR(I)
2980 ENDDO
2981C Elimination des noeuds doubles pour anim
2982 TOLE=EM05*FAC_LENGTH
2983 TOLE2=TOLE**2
2984 NNS_ANIM=0
2985 IF (ILVOUT/=0) WRITE(ISTDO,'(a25,i10,a39)')
2986 . ' ** monitored volume id: ',IVOLU(1),
2987 . ' - merging coincident nodes for anim **'
2988 ALLOCATE(PNODES(3,NNS+NNS2))
2989 DO I=1,NNS
2990 IF (FVDATA(IFV)%IFVNOD(1,I)==1) THEN
2991 IEL=FVDATA(IFV)%IFVNOD(2,I)
2992 KSI=FVDATA(IFV)%RFVNOD(1,I)
2993 ETA=FVDATA(IFV)%RFVNOD(2,I)
2994 N1=ELEMA(1,IEL)
2995 N2=ELEMA(2,IEL)
2996 N3=ELEMA(3,IEL)
2997 IF (TAGELA(IEL)>0) THEN
2998 X1=XXX(1,N1)
2999 Y1=XXX(2,N1)
3000 Z1=XXX(3,N1)
3001 X2=XXX(1,N2)
3002 Y2=XXX(2,N2)
3003 Z2=XXX(3,N2)
3004 X3=XXX(1,N3)
3005 Y3=XXX(2,N3)
3006 Z3=XXX(3,N3)
3007 ELSEIF (TAGELA(IEL)<0) THEN
3008 X1=XXXA(1,N1)
3009 Y1=XXXA(2,N1)
3010 Z1=XXXA(3,N1)
3011 X2=XXXA(1,N2)
3012 Y2=XXXA(2,N2)
3013 Z2=XXXA(3,N2)
3014 X3=XXXA(1,N3)
3015 Y3=XXXA(2,N3)
3016 Z3=XXXA(3,N3)
3017 ENDIF
3018 PNODES(1,I)=(ONE-KSI-ETA)*X1+KSI*X2+ETA*X3
3019 PNODES(2,I)=(ONE-KSI-ETA)*Y1+KSI*Y2+ETA*Y3
3020 PNODES(3,I)=(ONE-KSI-ETA)*Z1+KSI*Z2+ETA*Z3
3021 ELSEIF (FVDATA(IFV)%IFVNOD(1,I)==2) THEN
3022c IF (NSPMD == 1) THEN
3023c II=FVDATA(IFV)%IFVNOD(2,I)
3024c PNODES(1,I)=X(1,II)
3025c PNODES(2,I)=X(2,II)
3026c PNODES(3,I)=X(3,II)
3027c ELSE
3028 II=FVDATA(IFV)%IFVNOD(2,I)
3029 PNODES(1,I)=XXXSA(1,II)
3030 PNODES(2,I)=XXXSA(2,II)
3031 PNODES(3,I)=XXXSA(3,II)
3032c ENDIF
3033 ENDIF
3034 ENDDO
3035 DO I=1,NNS2
3036 II=NNS+I
3037 I1=FVDATA(IFV)%IFVNOD(2,II)
3038 I2=FVDATA(IFV)%IFVNOD(3,II)
3039 ALPHA=FVDATA(IFV)%RFVNOD(1,II)
3040 PNODES(1,II)=ALPHA*PNODES(1,I1)+(ONE-ALPHA)*PNODES(1,I2)
3041 PNODES(2,II)=ALPHA*PNODES(2,I1)+(ONE-ALPHA)*PNODES(2,I2)
3042 PNODES(3,II)=ALPHA*PNODES(3,I1)+(ONE-ALPHA)*PNODES(3,I2)
3043 ENDDO
3044 DO I=1,NNS+NNS2
3045 IF (ILVOUT<0) CALL PROGBAR_C(I,NNS+NNS2)
3046C
3047 XX=PNODES(1,I)
3048 YY=PNODES(2,I)
3049 ZZ=PNODES(3,I)
3050 IFOUND=0
3051 DO J=1,NNS_ANIM
3052 XN(1)=FVDATA(IFV)%NOD_ANIM(1,J)
3053 XN(2)=FVDATA(IFV)%NOD_ANIM(2,J)
3054 XN(3)=FVDATA(IFV)%NOD_ANIM(3,J)
3055 DD2=(XX-XN(1))**2+(YY-XN(2))**2+(ZZ-XN(3))**2
3056 IF (DD2<=TOLE2) THEN
3057 IFOUND=J
3058 EXIT
3059 ENDIF
3060 ENDDO
3061 IF (IFOUND==0) THEN
3062 NNS_ANIM=NNS_ANIM+1
3063 REDIR(I)=NNS_ANIM
3064 FVDATA(IFV)%REDIR_ANIM(NNS_ANIM)=I
3065 FVDATA(IFV)%NOD_ANIM(1,NNS_ANIM)=XX
3066 FVDATA(IFV)%NOD_ANIM(2,NNS_ANIM)=YY
3067 FVDATA(IFV)%NOD_ANIM(3,NNS_ANIM)=ZZ
3068 ELSE
3069 REDIR(I)=IFOUND
3070 ENDIF
3071 ENDDO
3072 FVDATA(IFV)%NNS_ANIM=NNS_ANIM
3073 FVDATA(IFV)%ID=IVOLU(1)
3074C
3075 DO I=1,NNTR
3076 N1=FVDATA(IFV)%IFVTRI(1,I)
3077 N2=FVDATA(IFV)%IFVTRI(2,I)
3078 N3=FVDATA(IFV)%IFVTRI(3,I)
3079 FVDATA(IFV)%IFVTRI_ANIM(1,I)=REDIR(N1)
3080 FVDATA(IFV)%IFVTRI_ANIM(2,I)=REDIR(N2)
3081 FVDATA(IFV)%IFVTRI_ANIM(3,I)=REDIR(N3)
3082 FVDATA(IFV)%IFVTRI_ANIM(4,I)=
3083 . FVDATA(IFV)%IFVTRI(4,I)
3084 FVDATA(IFV)%IFVTRI_ANIM(5,I)=
3085 . FVDATA(IFV)%IFVTRI(5,I)
3086 FVDATA(IFV)%IFVTRI_ANIM(6,I)=
3087 . FVDATA(IFV)%IFVTRI(6,I)
3088 ENDDO
3089 DEALLOCATE(PNODES)
3090C
3091 DEALLOCATE(REDIR, ITAGT)
3092 DEALLOCATE(XXXSA)
3093C
3094 RETURN
3095C
3096 END
3097C
3098!||====================================================================
3099!|| itribox ../engine/source/airbag/fvmesh.F
3100!||--- called by ------------------------------------------------------
3101!|| fvmesh1 ../engine/source/airbag/fvmesh.F
3102!||--- calls -----------------------------------------------------
3103!|| polclip ../engine/source/airbag/fvmesh.F
3104!||====================================================================
3105 SUBROUTINE ITRIBOX(TRI , BOX, NORM, NVERTS, POLY,
3106 . NVMAX)
3107C-----------------------------------------------
3108C I m p l i c i t T y p e s
3109C-----------------------------------------------
3110#include "implicit_f.inc"
3111C-----------------------------------------------
3112C D u m m y A r g u m e n t s
3113C-----------------------------------------------
3114 INTEGER NVERTS, NVMAX
3115 my_real
3116 . TRI(3,*), BOX(3,*), NORM(3,*), POLY(3,*)
3117C-----------------------------------------------
3118C L o c a l V a r i a b l e s
3119C-----------------------------------------------
3120 INTEGER I, NPOUT, J
3121 my_real
3122 . A(3), N(3), POLYOUT(3,NVMAX)
3123 INTEGER P_REF(6)
3124 DATA P_REF /1,5,1,2,3,4/
3125C
3126C Intersection triangle-box
3127 NVERTS=3
3128 DO I=1,NVERTS
3129 POLY(1,I)=TRI(1,I)
3130 POLY(2,I)=TRI(2,I)
3131 POLY(3,I)=TRI(3,I)
3132 ENDDO
3133C
3134 DO I=1,6
3135 A(1)=BOX(1,P_REF(I))
3136 A(2)=BOX(2,P_REF(I))
3137 A(3)=BOX(3,P_REF(I))
3138 N(1)=NORM(1,I)
3139 N(2)=NORM(2,I)
3140 N(3)=NORM(3,I)
3141 CALL POLCLIP(POLY, NVERTS, A, N, POLYOUT,
3142 . NPOUT)
3143 NVERTS=NPOUT
3144 DO J=1,NVERTS
3145 POLY(1,J)=POLYOUT(1,J)
3146 POLY(2,J)=POLYOUT(2,J)
3147 POLY(3,J)=POLYOUT(3,J)
3148 ENDDO
3149 ENDDO
3150C
3151 RETURN
3152 END
3153C
3154!||====================================================================
3155!|| polclip ../engine/source/airbag/fvmesh.F
3156!||--- called by ------------------------------------------------------
3157!|| itribox ../engine/source/airbag/fvmesh.F
3158!||====================================================================
3159 SUBROUTINE POLCLIP(POLYIN, NPIN, A, N, POLYOUT,
3160 . NPOUT )
3161C-----------------------------------------------
3162C I m p l i c i t T y p e s
3163C-----------------------------------------------
3164#include "implicit_f.inc"
3165C-----------------------------------------------
3166C D u m m y A r g u m e n t s
3167C-----------------------------------------------
3168 INTEGER NPIN, NPOUT
3169 my_real
3170 . POLYIN(3,*), A(*), N(*), POLYOUT(3,*)
3171C-----------------------------------------------
3172C L o c a l V a r i a b l e s
3173C-----------------------------------------------
3174 INTEGER I, II, IC1, IC2
3175 my_real
3176 . X1, Y1, Z1, X2, Y2, Z2, SS1, SS2, X12, Y12, Z12,
3177 . XA1, YA1, ZA1, ALPHA, XM, YM, ZM, SSN
3178C
3179 my_real
3180 . DLAMCH
3181 EXTERNAL DLAMCH
3182C
3183C Clipping d'un polygone par un plan
3184 NPOUT=0
3185 DO I=1,NPIN
3186 IF (I/=NPIN) THEN
3187 II=I+1
3188 ELSE
3189 II=1
3190 ENDIF
3191C
3192 X1=POLYIN(1,I)
3193 Y1=POLYIN(2,I)
3194 Z1=POLYIN(3,I)
3195 X2=POLYIN(1,II)
3196 Y2=POLYIN(2,II)
3197 Z2=POLYIN(3,II)
3198C
3199 SS1=(X1-A(1))*N(1)+(Y1-A(2))*N(2)+(Z1-A(3))*N(3)
3200 SS2=(X2-A(1))*N(1)+(Y2-A(2))*N(2)+(Z2-A(3))*N(3)
3201.AND. IF (SS1<ZEROSS2<ZERO) CYCLE
3202.AND. IF (SS1>=ZEROSS2>=ZERO) THEN
3203 NPOUT=NPOUT+1
3204 POLYOUT(1,NPOUT)=X1
3205 POLYOUT(2,NPOUT)=Y1
3206 POLYOUT(3,NPOUT)=Z1
3207 CYCLE
3208 ENDIF
3209C
3210 X12=X2-X1
3211 Y12=Y2-Y1
3212 Z12=Z2-Z1
3213 XA1=X1-A(1)
3214 YA1=Y1-A(2)
3215 ZA1=Z1-A(3)
3216 SSN=X12*N(1)+Y12*N(2)+Z12*N(3)
3217 ALPHA=-(XA1*N(1)+YA1*N(2)+ZA1*N(3))/SSN
3218 XM=X1+ALPHA*X12
3219 YM=Y1+ALPHA*Y12
3220 ZM=Z1+ALPHA*Z12
3221 IF (SS1>=ZERO) THEN
3222 NPOUT=NPOUT+1
3223 POLYOUT(1,NPOUT)=X1
3224 POLYOUT(2,NPOUT)=Y1
3225 POLYOUT(3,NPOUT)=Z1
3226 NPOUT=NPOUT+1
3227 POLYOUT(1,NPOUT)=XM
3228 POLYOUT(2,NPOUT)=YM
3229 POLYOUT(3,NPOUT)=ZM
3230 ELSEIF (SS2>=ZERO) THEN
3231 NPOUT=NPOUT+1
3232 POLYOUT(1,NPOUT)=XM
3233 POLYOUT(2,NPOUT)=YM
3234 POLYOUT(3,NPOUT)=ZM
3235 ENDIF
3236 ENDDO
3237C
3238 RETURN
3239 END
3240C
3241!||====================================================================
3242!|| facepoly ../engine/source/airbag/fvmesh.F
3243!||--- called by ------------------------------------------------------
3244!|| fvmesh1 ../engine/source/airbag/fvmesh.F
3245!||--- calls -----------------------------------------------------
3246!|| ancmsg ../engine/source/output/message/message.F
3247!|| arret ../engine/source/system/arret.F
3248!||--- uses -----------------------------------------------------
3249!|| message_mod ../engine/share/message_module/message_mod.F
3250!||====================================================================
3251 SUBROUTINE FACEPOLY(QUAD , TRI , NTRI , IPOLY, RPOLY ,
3252 . N , NORMF, NORMT , NSMAX, NNP ,
3253 . NRPMAX, NB , NV , LMIN , NPOLMAX,
3254 . NPPMAX, INFO , IELNOD, XXX , ELEMA ,
3255 . IBUF , NELA , IBRIC , IFAC , MVID ,
3256 . ILVOUT, IBUFA, TAGELA, XXXA )
3257 USE MESSAGE_MOD
3258C-----------------------------------------------
3259C I m p l i c i t T y p e s
3260C-----------------------------------------------
3261#include "implicit_f.inc"
3262C-----------------------------------------------
3263C D u m m y A r g u m e n t s
3264C-----------------------------------------------
3265 INTEGER TRI(NSMAX,*), NTRI, NPPMAX, IPOLY(6+NPPMAX+1+NPOLMAX,*),
3266 . NSMAX, NRPMAX, NNP, NB, NV, NPOLMAX, INFO,
3267 . IELNOD(NPPMAX,*), ELEMA(3,*), IBUF(*), NELA, IBRIC, IFAC,
3268 . MVID, ILVOUT, IBUFA(*), TAGELA(*)
3269 my_real
3270 . QUAD(3,*), RPOLY(NRPMAX+3*NPOLMAX,*), N(*), NORMF(3,*),
3271 . NORMT(3,*), LMIN, XXX(3,*), XXXA(3,*)
3272C-----------------------------------------------
3273C L o c a l V a r i a b l e s
3274C-----------------------------------------------
3275 INTEGER I, NINTER(4), NP, J, JJ, IDBL, NPI, NSEG, REDIR(NTRI), K,
3276 . KK, JJ1, NNO, ID1, ID2, ISEG(3,5*NTRI), NSEGF, ISTOP,
3277 . ISSEG, IPSEG, ITAGSEG(5*NTRI), ITAG(5*NTRI*2), ICLOSE,
3278 . INEXT, NN, NPOLY, IADPOLY(NTRI), LENPOLY(NTRI), IAD, II,
3279 . POLY(2,5*NTRI+1), I0, JJJ, REDIR_TMP(NTRI), NPI_TMP,
3280 . ELSEG(5*NTRI,2), ELINTER(4,NTRI), ELNODE(5*NTRI*2),
3281 . NNS, LENMAX, NEDGE, J1, J2, IEDGE, K1, K2,
3282 . TEDGE(3*NTRI,3), EDGE(3*NTRI,3), N1, N2, IPOUT, M, MM,
3283 . NHOL, IADHOL(NPOLMAX), ISEG3_OLD(5*NTRI), IDIFF, NSEC,
3284 . KSMIN
3285 my_real
3286 . TOLE, TOLE2, A(3), X1, Y1, Z1, X2, Y2, Z2, SS1, SS2,
3287 . X12, Y12, Z12, XA1, YA1, ZA1, ALPHA, XM, YM, ZM,
3288 . STMP(4,3), SEG(5*NTRI,3,2), NX, NY, NZ, XA2, YA2, ZA2,
3289 . XA12, YA12, ZA12, XA1P1, YA1P1, ZA1P1, BETA,
3290 . PINTER(4,NTRI,4), XL(NTRI), XLREF, XP1, YP1, ZP1, XP2,
3291 . YP2, ZP2, NODE(3,5*NTRI*2), XX1, YY1, ZZ1, DD1, DD2,
3292 . XLC, LL, TOLEI, T1, T2, DD, XA1P2, YA1P2, ZA1P2,
3293 . XEDGE(3*NTRI,4), XX2, YY2, ZZ2, NR1, NR2, VX1, VY1, VZ1,
3294 . VX2, VY2, VZ2, SS, VVX, VVY, VVZ, XX, YY, ZZ,
3295 . PHOL(3,NPOLMAX), XLOC(2,NPPMAX), XSEC(NPPMAX), YLMIN,
3296 . YLMAX, YLSEC, XSMIN1, XSMIN2, XS, YS
3297C
3298C
3299* TOLE2=EM5
3300 TOLE2 = ZERO
3301 TOLE2 = EPSILON(TOLE2)
3302 TOLEI=TOLE2*TEN
3303 TOLE=TOLE2*LMIN
3304C
3305 A(1)=QUAD(1,1)
3306 A(2)=QUAD(2,1)
3307 A(3)=QUAD(3,1)
3308C Recensement des aretes de triangles
3309 NEDGE=0
3310 DO I=1,NTRI
3311 DO J=1,3
3312 JJ=J+1
3313 IF (J==3) JJ=1
3314 J1=TRI(I,J)
3315 J2=TRI(I,JJ)
3316 IEDGE=0
3317 DO K=1,NEDGE
3318 K1=EDGE(K,1)
3319 K2=EDGE(K,2)
3320.AND..OR. IF ((K1==J1K2==J2)
3321.AND. . (K2==J1K1==J2)) IEDGE=K
3322 ENDDO
3323 IF (IEDGE==0) THEN
3324 NEDGE=NEDGE+1
3325 TEDGE(I,J)=NEDGE
3326 EDGE(NEDGE,1)=J1
3327 EDGE(NEDGE,2)=J2
3328 ELSE
3329 TEDGE(I,J)=IEDGE
3330 ENDIF
3331 ENDDO
3332 ENDDO
3333C Calcul des intersections des aretes avec le plan de la facette
3334 DO I=1,NEDGE
3335 N1=EDGE(I,1)
3336 N2=EDGE(I,2)
3337 IF (N1>0) THEN
3338 X1=XXX(1,N1)
3339 Y1=XXX(2,N1)
3340 Z1=XXX(3,N1)
3341 ELSEIF (N1<0) THEN
3342 X1=XXXA(1,-N1)
3343 Y1=XXXA(2,-N1)
3344 Z1=XXXA(3,-N1)
3345 ENDIF
3346 IF (N2>0) THEN
3347 X2=XXX(1,N2)
3348 Y2=XXX(2,N2)
3349 Z2=XXX(3,N2)
3350 ELSEIF (N2<0) THEN
3351 X2=XXXA(1,-N2)
3352 Y2=XXXA(2,-N2)
3353 Z2=XXXA(3,-N2)
3354 ENDIF
3355 SS1=(X1-A(1))*N(1)+(Y1-A(2))*N(2)+(Z1-A(3))*N(3)
3356 SS2=(X2-A(1))*N(1)+(Y2-A(2))*N(2)+(Z2-A(3))*N(3)
3357 EDGE(I,3)=0
3358.OR. IF (ABS(SS1)<=TOLEABS(SS2)<=TOLE) THEN
3359.AND. IF (ABS(SS1)<=TOLEABS(SS2)<=TOLE) CYCLE
3360.AND. ELSEIF (SS1<ZEROSS2<ZERO) THEN
3361 CYCLE
3362.AND. ELSEIF (SS1>=ZEROSS2>=ZERO) THEN
3363 CYCLE
3364 ENDIF
3365 X12=X2-X1
3366 Y12=Y2-Y1
3367 Z12=Z2-Z1
3368 XA1=X1-A(1)
3369 YA1=Y1-A(2)
3370 ZA1=Z1-A(3)
3371 ALPHA=-(XA1*N(1)+YA1*N(2)+ZA1*N(3))
3372 . /(X12*N(1)+Y12*N(2)+Z12*N(3))
3373 XM=X1+ALPHA*X12
3374 YM=Y1+ALPHA*Y12
3375 ZM=Z1+ALPHA*Z12
3376C
3377 EDGE(I,3)=1
3378 XEDGE(I,1)=XM
3379 XEDGE(I,2)=YM
3380 XEDGE(I,3)=ZM
3381 XEDGE(I,4)=SS1*SS2
3382 ENDDO
3383C Calcul des intersections des triangles avec le plan de la facette (segments)
3384 DO I=1,4
3385 NINTER(I)=0
3386 ENDDO
3387 DO I=1,NTRI
3388 NP=0
3389 ELSEG(I,1)=I
3390 ELSEG(I,2)=I
3391 DO J=1,3
3392 IEDGE=TEDGE(I,J)
3393 IF (EDGE(IEDGE,3)==0) CYCLE
3394 NP=NP+1
3395 STMP(1,NP)=XEDGE(IEDGE,1)
3396 STMP(2,NP)=XEDGE(IEDGE,2)
3397 STMP(3,NP)=XEDGE(IEDGE,3)
3398 STMP(4,NP)=XEDGE(IEDGE,4)
3399 ENDDO
3400 IF (NP==0) THEN
3401 SEG(I,1,1)=ZERO
3402 SEG(I,2,1)=ZERO
3403 SEG(I,3,1)=ZERO
3404 SEG(I,1,2)=ZERO
3405 SEG(I,2,2)=ZERO
3406 SEG(I,3,2)=ZERO
3407 CYCLE
3408 ELSEIF (NP==3) THEN
3409 NP=0
3410 IDBL=0
3411 DO J=1,3
3412 IF (STMP(4,J)<ZERO) THEN
3413 NP=NP+1
3414 SEG(I,1,NP)=STMP(1,J)
3415 SEG(I,2,NP)=STMP(2,J)
3416 SEG(I,3,NP)=STMP(3,J)
3417 ELSEIF (STMP(4,J)==ZERO) THEN
3418 IF (IDBL==0) THEN
3419 NP=NP+1
3420 SEG(I,1,NP)=STMP(1,J)
3421 SEG(I,2,NP)=STMP(2,J)
3422 SEG(I,3,NP)=STMP(3,J)
3423 IDBL=1
3424 ENDIF
3425 ENDIF
3426 ENDDO
3427 ELSEIF (NP==2) THEN
3428 SEG(I,1,1)=STMP(1,1)
3429 SEG(I,2,1)=STMP(2,1)
3430 SEG(I,3,1)=STMP(3,1)
3431 SEG(I,1,2)=STMP(1,2)
3432 SEG(I,2,2)=STMP(2,2)
3433 SEG(I,3,2)=STMP(3,2)
3434 ENDIF
3435C Intersection (eventuelle) de chaque segment avec les aretes de la facette
3436 DO J=1,4
3437 NPI=NINTER(J)
3438 IF (J/=4) THEN
3439 JJ=J+1
3440 ELSE
3441 JJ=1
3442 ENDIF
3443 NX=NORMF(1,J)
3444 NY=NORMF(2,J)
3445 NZ=NORMF(3,J)
3446 X1=SEG(I,1,1)
3447 Y1=SEG(I,2,1)
3448 Z1=SEG(I,3,1)
3449 X2=SEG(I,1,2)
3450 Y2=SEG(I,2,2)
3451 Z2=SEG(I,3,2)
3452 X12=X2-X1
3453 Y12=Y2-Y1
3454 Z12=Z2-Z1
3455 XA1=QUAD(1,J)
3456 YA1=QUAD(2,J)
3457 ZA1=QUAD(3,J)
3458 XA2=QUAD(1,JJ)
3459 YA2=QUAD(2,JJ)
3460 ZA2=QUAD(3,JJ)
3461 XA12=XA2-XA1
3462 YA12=YA2-YA1
3463 ZA12=ZA2-ZA1
3464 XA1P1=X1-XA1
3465 YA1P1=Y1-YA1
3466 ZA1P1=Z1-ZA1
3467 XA1P2=X2-XA1
3468 YA1P2=Y2-YA1
3469 ZA1P2=Z2-ZA1
3470C
3471 SS1=XA1P1*NX+YA1P1*NY+ZA1P1*NZ
3472 SS2=XA1P2*NX+YA1P2*NY+ZA1P2*NZ
3473.AND. IF (SS1>ZEROSS2>ZERO) THEN
3474 SEG(I,1,1)=ZERO
3475 SEG(I,2,1)=ZERO
3476 SEG(I,3,1)=ZERO
3477 SEG(I,1,2)=ZERO
3478 SEG(I,2,2)=ZERO
3479 SEG(I,3,2)=ZERO
3480 CYCLE
3481 ENDIF
3482C
3483 SS2=X12*NX+Y12*NY+Z12*NZ
3484 IF (SS2==ZERO) CYCLE
3485 ALPHA=-SS1/SS2
3486.OR. IF (ALPHA<-TOLEIALPHA>ONE+TOLEI) CYCLE
3487 XM=X1+ALPHA*X12
3488 YM=Y1+ALPHA*Y12
3489 ZM=Z1+ALPHA*Z12
3490 BETA=((XM-XA1)*XA12+(YM-YA1)*YA12+(ZM-ZA1)*ZA12)
3491 . /(XA12**2+YA12**2+ZA12**2)
3492.OR. IF (BETA<-TOLEIBETA>ONE+TOLEI) CYCLE
3493 SS1=(X1-XA1)*NX+(Y1-YA1)*NY+(Z1-ZA1)*NZ
3494 SS2=(X2-XA1)*NX+(Y2-YA1)*NY+(Z2-ZA1)*NZ
3495C
3496 IF (SS1*SS2>ZERO) THEN
3497 IF (ABS(SS1)<=ABS(SS2)) THEN
3498 SEG(I,1,1)=XM
3499 SEG(I,2,1)=YM
3500 SEG(I,3,1)=ZM
3501 ELSE
3502 SEG(I,1,2)=XM
3503 SEG(I,2,2)=YM
3504 SEG(I,3,2)=ZM
3505 ENDIF
3506 ELSEIF (SS1*SS2<ZERO) THEN
3507 IF (SS1<ZERO) THEN
3508 SEG(I,1,2)=XM
3509 SEG(I,2,2)=YM
3510 SEG(I,3,2)=ZM
3511 ELSEIF (SS2<ZERO) THEN
3512 SEG(I,1,1)=XM
3513 SEG(I,2,1)=YM
3514 SEG(I,3,1)=ZM
3515 ENDIF
3516 ELSE
3517 IF (SS1==ZERO) THEN
3518 IF (SS2<ZERO) THEN
3519 SEG(I,1,1)=XM
3520 SEG(I,2,1)=YM
3521 SEG(I,3,1)=ZM
3522 ELSEIF (SS2>=ZERO) THEN
3523 SEG(I,1,2)=XM
3524 SEG(I,2,2)=YM
3525 SEG(I,3,2)=ZM
3526 ENDIF
3527 ELSEIF (SS2==ZERO) THEN
3528 IF (SS1<ZERO) THEN
3529 SEG(I,1,2)=XM
3530 SEG(I,2,2)=YM
3531 SEG(I,3,2)=ZM
3532 ELSEIF (SS1>=ZERO) THEN
3533 SEG(I,1,1)=XM
3534 SEG(I,2,1)=YM
3535 SEG(I,3,1)=ZM
3536 ENDIF
3537 ENDIF
3538 ENDIF
3539C
3540 NPI=NPI+1
3541 NINTER(J)=NPI
3542 PINTER(J,NPI,1)=XM
3543 PINTER(J,NPI,2)=YM
3544 PINTER(J,NPI,3)=ZM
3545 ELINTER(J,NPI)=I
3546 NX=NORMT(1,I)
3547 NY=NORMT(2,I)
3548 NZ=NORMT(3,I)
3549 SS1=XA12*NX+YA12*NY+ZA12*NZ
3550 IF (SS1<=ZERO) THEN
3551 PINTER(J,NPI,4)=ONE
3552 ELSEIF (SS1>=ZERO) THEN
3553 PINTER(J,NPI,4)=-ONE
3554 ENDIF
3555 ENDDO
3556 ENDDO
3557C
3558 NSEG=NTRI
3559 DO I=1,4
3560 IF (I/=4) THEN
3561 II=I+1
3562 ELSE
3563 II=1
3564 ENDIF
3565 XA1=QUAD(1,I)
3566 YA1=QUAD(2,I)
3567 ZA1=QUAD(3,I)
3568 XA2=QUAD(1,II)
3569 YA2=QUAD(2,II)
3570 ZA2=QUAD(3,II)
3571 XA12=XA2-XA1
3572 YA12=YA2-YA1
3573 ZA12=ZA2-ZA1
3574 IF (NINTER(I)==0) CYCLE
3575C Tri des points sur les bords de l'arete
3576 NPI=NINTER(I)
3577 DO J=1,NPI
3578 XM=PINTER(I,J,1)
3579 YM=PINTER(I,J,2)
3580 ZM=PINTER(I,J,3)
3581 XL(J)=((XM-XA1)*XA12+(YM-YA1)*YA12+(ZM-ZA1)*ZA12)
3582 . /(XA12**2+YA12**2+ZA12**2)
3583 ENDDO
3584 DO J=1,NPI
3585 REDIR(J)=J
3586 ENDDO
3587 DO J=1,NPI
3588 XLREF=XL(REDIR(J))
3589 DO K=J+1,NPI
3590 XLC=XL(REDIR(K))
3591 IF (XLC<=XLREF) THEN
3592 KK=REDIR(K)
3593 REDIR(K)=REDIR(J)
3594 REDIR(J)=KK
3595 XLREF=XLC
3596 ENDIF
3597 ENDDO
3598 ENDDO
3599C Identification des doubles
3600 DO J=1,NPI
3601 JJ=REDIR(J)
3602 IF (JJ>0) THEN
3603 X1=PINTER(I,JJ,1)
3604 Y1=PINTER(I,JJ,2)
3605 Z1=PINTER(I,JJ,3)
3606 T1=PINTER(I,JJ,4)
3607 DO K=J+1,NPI
3608 KK=REDIR(K)
3609 IF (KK>0) THEN
3610 X2=PINTER(I,KK,1)
3611 Y2=PINTER(I,KK,2)
3612 Z2=PINTER(I,KK,3)
3613 T2=PINTER(I,KK,4)
3614 DD=(X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2+(T2-T1)**2
3615 IF (DD<=TOLE) REDIR(K)=0
3616 ENDIF
3617 ENDDO
3618 ENDIF
3619 ENDDO
3620C Elimination des segments de longueur nulle
3621 DO J=1,NPI
3622 JJ=REDIR(J)
3623 IF (JJ>0) THEN
3624 X1=PINTER(I,JJ,1)
3625 Y1=PINTER(I,JJ,2)
3626 Z1=PINTER(I,JJ,3)
3627 DO K=J+1,NPI
3628 KK=REDIR(K)
3629 IF (KK>0) THEN
3630 X2=PINTER(I,KK,1)
3631 Y2=PINTER(I,KK,2)
3632 Z2=PINTER(I,KK,3)
3633 DD=(X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2
3634 IF (DD<=TOLE) THEN
3635 REDIR(J)=0
3636 REDIR(K)=0
3637 ENDIF
3638 ENDIF
3639 ENDDO
3640 ENDIF
3641 ENDDO
3642C Condensation du tableau REDIR
3643 DO J=1,NPI
3644 REDIR_TMP(J)=REDIR(J)
3645 ENDDO
3646 NPI_TMP=NPI
3647 NPI=0
3648 DO J=1,NPI_TMP
3649 IF (REDIR_TMP(J)>0) THEN
3650 NPI=NPI+1
3651 REDIR(NPI)=REDIR_TMP(J)
3652 ENDIF
3653 ENDDO
3654 IF (NPI==0) CYCLE
3655C Creation des segments sur les aretes
3656 IF (PINTER(I,REDIR(1),4)==-ONE) THEN
3657 NSEG=NSEG+1
3658 SEG(NSEG,1,1)=XA1
3659 SEG(NSEG,2,1)=YA1
3660 SEG(NSEG,3,1)=ZA1
3661 ELSEG(NSEG,1)=0
3662 SEG(NSEG,1,2)=PINTER(I,REDIR(1),1)
3663 SEG(NSEG,2,2)=PINTER(I,REDIR(1),2)
3664 SEG(NSEG,3,2)=PINTER(I,REDIR(1),3)
3665 ELSEG(NSEG,2)=ELINTER(I,REDIR(1))
3666 ENDIF
3667 DO J=1,NPI-1
3668 JJ=REDIR(J)
3669 JJ1=REDIR(J+1)
3670 IF (PINTER(I,JJ,4)==-ONE) CYCLE
3671 XP1=PINTER(I,JJ,1)
3672 YP1=PINTER(I,JJ,2)
3673 ZP1=PINTER(I,JJ,3)
3674 XP2=PINTER(I,JJ1,1)
3675 YP2=PINTER(I,JJ1,2)
3676 ZP2=PINTER(I,JJ1,3)
3677 NSEG=NSEG+1
3678 SEG(NSEG,1,1)=XP1
3679 SEG(NSEG,2,1)=YP1
3680 SEG(NSEG,3,1)=ZP1
3681 ELSEG(NSEG,1)=ELINTER(I,JJ)
3682 SEG(NSEG,1,2)=XP2
3683 SEG(NSEG,2,2)=YP2
3684 SEG(NSEG,3,2)=ZP2
3685 ELSEG(NSEG,2)=ELINTER(I,JJ1)
3686 ENDDO
3687 IF (PINTER(I,REDIR(NPI),4)==ONE) THEN
3688 NSEG=NSEG+1
3689 SEG(NSEG,1,1)=PINTER(I,REDIR(NPI),1)
3690 SEG(NSEG,2,1)=PINTER(I,REDIR(NPI),2)
3691 SEG(NSEG,3,1)=PINTER(I,REDIR(NPI),3)
3692 ELSEG(NSEG,1)=ELINTER(I,REDIR(NPI))
3693 SEG(NSEG,1,2)=XA2
3694 SEG(NSEG,2,2)=YA2
3695 SEG(NSEG,3,2)=ZA2
3696 ELSEG(NSEG,2)=0
3697 ENDIF
3698 ENDDO
3699C Recensement des noeuds
3700 NNO=0
3701 DO I=1,NSEG
3702 X1=SEG(I,1,1)
3703 Y1=SEG(I,2,1)
3704 Z1=SEG(I,3,1)
3705 X2=SEG(I,1,2)
3706 Y2=SEG(I,2,2)
3707 Z2=SEG(I,3,2)
3708.AND..AND..AND. IF (X1==ZEROY1==ZEROZ1==ZERO
3709.AND..AND. . X2==ZEROY2==ZEROZ2==ZERO) THEN
3710 ISEG(1,I)=0
3711 ISEG(2,I)=0
3712 ISEG(3,I)=1
3713 CYCLE
3714 ENDIF
3715 ID1=0
3716 ID2=0
3717 DO J=1,NNO
3718 XX1=NODE(1,J)
3719 YY1=NODE(2,J)
3720 ZZ1=NODE(3,J)
3721 DD1=(XX1-X1)**2+(YY1-Y1)**2+(ZZ1-Z1)**2
3722 DD2=(XX1-X2)**2+(YY1-Y2)**2+(ZZ1-Z2)**2
3723 IF (DD1<=TOLE) ID1=J
3724 IF (DD2<=TOLE) ID2=J
3725 ENDDO
3726 LL=(X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2
3727 IF (ID1==0) THEN
3728 NNO=NNO+1
3729 NODE(1,NNO)=X1
3730 NODE(2,NNO)=Y1
3731 NODE(3,NNO)=Z1
3732 ELNODE(NNO)=ELSEG(I,1)
3733 ID1=NNO
3734 ENDIF
3735 IF (LL<=TOLE) ID2=ID1
3736 IF (ID2==0) THEN
3737 NNO=NNO+1
3738 NODE(1,NNO)=X2
3739 NODE(2,NNO)=Y2
3740 NODE(3,NNO)=Z2
3741 ELNODE(NNO)=ELSEG(I,2)
3742 ID2=NNO
3743 ENDIF
3744 ISEG(1,I)=ID1
3745 ISEG(2,I)=ID2
3746 ISEG(3,I)=0
3747 IF (ID1==ID2) ISEG(3,I)=1
3748 ENDDO
3749C Elimination des segments doubles
3750 DO I=1,NSEG
3751 IF (ISEG(3,I)==1) CYCLE
3752 ID1=ISEG(1,I)
3753 ID2=ISEG(2,I)
3754 DO J=I+1,NSEG
3755.AND..OR. IF ((ISEG(1,J)==ID1ISEG(2,J)==ID2)
3756.AND. . (ISEG(1,J)==ID2ISEG(2,J)==ID1)) ISEG(3,J)=1
3757 ENDDO
3758 ENDDO
3759C
3760 NSEGF=0
3761 DO I=1,NSEG
3762 IF (ISEG(3,I)==0) NSEGF=NSEGF+1
3763 ENDDO
3764 IF (NSEGF<=1) RETURN
3765C
3766C Reconstruction des polygones
3767 ISTOP=0
3768 NPOLY=0
3769 NP=0
3770C
3771 DO I=1,NSEG
3772 ISEG3_OLD(I)=ISEG(3,I)
3773 ENDDO
3774C
3775 DO WHILE (ISTOP==0)
3776 I=1
3777.AND. DO WHILE (ISEG(3,I)==1I<=NSEG)
3778 I=I+1
3779 ENDDO
3780 IF (I==NSEG+1) THEN
3781 ISTOP=1
3782 CYCLE
3783 ENDIF
3784 ISSEG=I
3785 IPSEG=2
3786 DO J=1,NNO
3787 ITAG(J)=0
3788 ENDDO
3789 DO J=1,NSEG
3790 ITAGSEG(J)=0
3791 ENDDO
3792 ITAG(ISEG(1,ISSEG))=I
3793 ITAGSEG(ISSEG)=I
3794 ICLOSE=0
3795 I0=I-1
3796.AND. DO WHILE (ICLOSE==0I<NSEG)
3797 I=I+1
3798 INEXT=0
3799 DO J=1,NSEG
3800.OR..OR. IF (J==ISSEGISEG(3,J)==1INEXT/=0) CYCLE
3801 ID1=ISEG(1,J)
3802 ID2=ISEG(2,J)
3803 IF (ID1==ISEG(IPSEG,ISSEG)) THEN
3804 INEXT=1
3805 ISSEG=J
3806 IPSEG=2
3807 ITAG(ISEG(1,ISSEG))=I
3808 ITAGSEG(J)=I
3809 ELSEIF (ID2==ISEG(IPSEG,ISSEG)) THEN
3810 INEXT=1
3811 ISSEG=J
3812 IPSEG=1
3813 ITAG(ISEG(2,ISSEG))=I
3814 ITAGSEG(J)=-I
3815 ENDIF
3816 ENDDO
3817 IF (INEXT==0) THEN
3818 ISEG(3,ISSEG)=1
3819 I=NSEG
3820 ELSE
3821 NN=ITAG(ISEG(IPSEG,ISSEG))
3822 IF (NN/=0) ICLOSE=NN
3823 ENDIF
3824 ENDDO
3825 IF (ICLOSE/=0) THEN
3826 NPOLY=NPOLY+1
3827 IADPOLY(NPOLY)=NP
3828 IAD=NP
3829 DO J=1,NSEG
3830 JJ=ITAGSEG(J)
3831 IF (ABS(JJ)>=ICLOSE) THEN
3832 NP=NP+1
3833 POLY(1,IAD+ABS(JJ)-I0)=J
3834 IF (JJ>0) THEN
3835 POLY(2,IAD+ABS(JJ)-I0)=2
3836 ELSEIF (JJ<0) THEN
3837 POLY(2,IAD+ABS(JJ)-I0)=1
3838 ENDIF
3839 ISEG(3,J)=1
3840 ENDIF
3841 ENDDO
3842 LENPOLY(NPOLY)=NP-IADPOLY(NPOLY)
3843 ENDIF
3844C
3845 IDIFF=0
3846 DO J=1,NSEG
3847 IDIFF=MAX(IDIFF,ABS(ISEG3_OLD(J)-ISEG(3,J)))
3848 ENDDO
3849 IF (IDIFF==0) THEN
3850 CALL ANCMSG(MSGID=9,ANMODE=ANINFO,
3851 . I1=MVID)
3852 IF (ILVOUT/=0) THEN
3853 CALL ANCMSG(MSGID=10,ANMODE=ANINFO_BLIND,
3854 . I1=IBRIC,I2=IFAC)
3855 END IF
3856 CALL ARRET(2)
3857 ENDIF
3858 ENDDO
3859C
3860 INFO=0
3861 IF (NPOLY>NPOLMAX) THEN
3862 NPOLMAX=NPOLY
3863 INFO=1
3864 ENDIF
3865 LENMAX=0
3866 DO I=1,NPOLY
3867 LENMAX=MAX(LENMAX,LENPOLY(I))
3868 ENDDO
3869 IF (LENMAX>NPPMAX) THEN
3870 NPPMAX=LENMAX
3871 INFO=1
3872 ENDIF
3873 IF (INFO==1) RETURN
3874 NNP=NPOLY
3875C
3876 NNS=0
3877 DO I=1,NPOLY
3878 IAD=IADPOLY(I)
3879 IPOLY(1,I)=2
3880 IPOLY(2,I)=LENPOLY(I)
3881 IPOLY(3,I)=NB
3882 IPOLY(4,I)=NV
3883 IPOLY(5,I)=0
3884 IPOLY(6,I)=0
3885 RPOLY(1,I)=ZERO
3886 RPOLY(2,I)=N(1)
3887 RPOLY(3,I)=N(2)
3888 RPOLY(4,I)=N(3)
3889 DO J=1,LENPOLY(I)
3890 JJ=POLY(1,IAD+J)
3891 JJJ=POLY(2,IAD+J)
3892 ID1=ISEG(JJJ,JJ)
3893 NNS=NNS+1
3894 IPOLY(6+J,I)=NNS
3895 IELNOD(J,I)=ELNODE(ID1)
3896 RPOLY(4+3*(J-1)+1,I)=NODE(1,ID1)
3897 RPOLY(4+3*(J-1)+2,I)=NODE(2,ID1)
3898 RPOLY(4+3*(J-1)+3,I)=NODE(3,ID1)
3899 ENDDO
3900 ENDDO
3901C
3902C Recherche des trous
3903 INFO=0
3904 DO I=1,NPOLY
3905C
3906 NHOL=0
3907 DO J=1,NPOLY
3908 IADHOL(J)=0
3909 ENDDO
3910C
3911 DO J=1,NPOLY
3912 IF (I==J) CYCLE
3913 ALPHA=ZERO
3914 X1=RPOLY(5,J)
3915 Y1=RPOLY(6,J)
3916 Z1=RPOLY(7,J)
3917 DO K=1,LENPOLY(I)
3918 KK=K+1
3919 IF (K==LENPOLY(I)) KK=1
3920 XX1=RPOLY(4+3*(K-1)+1,I)
3921 YY1=RPOLY(4+3*(K-1)+2,I)
3922 ZZ1=RPOLY(4+3*(K-1)+3,I)
3923 XX2=RPOLY(4+3*(KK-1)+1,I)
3924 YY2=RPOLY(4+3*(KK-1)+2,I)
3925 ZZ2=RPOLY(4+3*(KK-1)+3,I)
3926 VX1=XX1-X1
3927 VY1=YY1-Y1
3928 VZ1=ZZ1-Z1
3929 VX2=XX2-X1
3930 VY2=YY2-Y1
3931 VZ2=ZZ2-Z1
3932 NR1=SQRT(VX1**2+VY1**2+VZ1**2)
3933 NR2=SQRT(VX2**2+VY2**2+VZ2**2)
3934 VX1=VX1/NR1
3935 VY1=VY1/NR1
3936 VZ1=VZ1/NR1
3937 VX2=VX2/NR2
3938 VY2=VY2/NR2
3939 VZ2=VZ2/NR2
3940 SS=VX1*VX2+VY1*VY2+VZ1*VZ2
3941 VVX=VY1*VZ2-VZ1*VY2
3942 VVY=VZ1*VX2-VX1*VZ2
3943 VVZ=VX1*VY2-VY1*VX2
3944 SS1=N(1)*VVX+N(2)*VVY+N(3)*VVZ
3945 IF (SS1>=ZERO) THEN
3946 ALPHA=ALPHA+ACOS(SS)
3947 ELSE
3948 ALPHA=ALPHA-ACOS(SS)
3949 ENDIF
3950 ENDDO
3951C
3952 IF (ABS(ALPHA)>=ONE) THEN
3953C Le premier point du polygone i est a l'interieur du polygone j
3954C On teste tous les autres
3955 IPOUT=0
3956 DO K=2,LENPOLY(J)
3957 X2=RPOLY(4+3*(K-1)+1,J)
3958 Y2=RPOLY(4+3*(K-1)+2,J)
3959 Z2=RPOLY(4+3*(K-1)+3,J)
3960 ALPHA=ZERO
3961 DO M=1,LENPOLY(I)
3962 MM=M+1
3963 IF (M==LENPOLY(I)) MM=1
3964 XX1=RPOLY(4+3*(M-1)+1,I)
3965 YY1=RPOLY(4+3*(M-1)+2,I)
3966 ZZ1=RPOLY(4+3*(M-1)+3,I)
3967 XX2=RPOLY(4+3*(MM-1)+1,I)
3968 YY2=RPOLY(4+3*(MM-1)+2,I)
3969 ZZ2=RPOLY(4+3*(MM-1)+3,I)
3970 VX1=XX1-X1
3971 VY1=YY1-Y1
3972 VZ1=ZZ1-Z1
3973 VX2=XX2-X1
3974 VY2=YY2-Y1
3975 VZ2=ZZ2-Z1
3976 NR1=SQRT(VX1**2+VY1**2+VZ1**2)
3977 NR2=SQRT(VX2**2+VY2**2+VZ2**2)
3978 VX1=VX1/NR1
3979 VY1=VY1/NR1
3980 VZ1=VZ1/NR1
3981 VX2=VX2/NR2
3982 VY2=VY2/NR2
3983 VZ2=VZ2/NR2
3984 SS=VX1*VX2+VY1*VY2+VZ1*VZ2
3985 VVX=VY1*VZ2-VZ1*VY2
3986 VVY=VZ1*VX2-VX1*VZ2
3987 VVZ=VX1*VY2-VY1*VX2
3988 SS1=N(1)*VVX+N(2)*VVY+N(3)*VVZ
3989 IF (SS1>=ZERO) THEN
3990 ALPHA=ALPHA+ACOS(SS)
3991 ELSE
3992 ALPHA=ALPHA-ACOS(SS)
3993 ENDIF
3994 ENDDO
3995 IF (ABS(ALPHA)<ONE) IPOUT=1
3996 ENDDO
3997C
3998 IF (IPOUT==1) CYCLE
3999C Le polygone j est un trou dans le polygone i
4000 IPOLY(1,J)=-1
4001 NHOL=NHOL+1
4002 IADHOL(NHOL)=LENPOLY(I)
4003 IF (LENPOLY(I)+LENPOLY(J)>NPPMAX) THEN
4004 NPPMAX=LENPOLY(I)+LENPOLY(J)
4005 INFO=1
4006 ELSE
4007 DO K=1,LENPOLY(J)
4008 IPOLY(6+IADHOL(NHOL)+K,I)=IPOLY(6+K,J)
4009 IELNOD(IADHOL(NHOL)+K,I)=IELNOD(K,J)
4010 RPOLY(4+3*IADHOL(NHOL)+3*(K-1)+1,I)=
4011 . RPOLY(4+3*(K-1)+1,J)
4012 RPOLY(4+3*IADHOL(NHOL)+3*(K-1)+2,I)=
4013 . RPOLY(4+3*(K-1)+2,J)
4014 RPOLY(4+3*IADHOL(NHOL)+3*(K-1)+3,I)=
4015 . RPOLY(4+3*(K-1)+3,J)
4016 ENDDO
4017 ENDIF
4018 LENPOLY(I)=LENPOLY(I)+LENPOLY(J)
4019C Point interieur polygone j
4020 VX1=QUAD(1,2)-QUAD(1,1)
4021 VY1=QUAD(2,2)-QUAD(2,1)
4022 VZ1=QUAD(3,2)-QUAD(3,1)
4023 SS=SQRT(VX1**2+VY1**2+VZ1**2)
4024 VX1=VX1/SS
4025 VY1=VY1/SS
4026 VZ1=VZ1/SS
4027 VX2=N(2)*VZ1-N(3)*VY1
4028 VY2=N(3)*VX1-N(1)*VZ1
4029 VZ2=N(1)*VY1-N(2)*VX1
4030 X1=RPOLY(5,J)
4031 Y1=RPOLY(6,J)
4032 Z1=RPOLY(7,J)
4033 XLOC(1,1)=ZERO
4034 XLOC(2,1)=ZERO
4035 YLMIN=EP30
4036 YLMAX=-EP30
4037 DO K=2,LENPOLY(J)
4038 XX=RPOLY(4+3*(K-1)+1,J)
4039 YY=RPOLY(4+3*(K-1)+2,J)
4040 ZZ=RPOLY(4+3*(K-1)+3,J)
4041 VVX=XX-X1
4042 VVY=YY-Y1
4043 VVZ=ZZ-Z1
4044 XLOC(1,K)=VVX*VX1+VVY*VY1+VVZ*VZ1
4045 XLOC(2,K)=VVX*VX2+VVY*VY2+VVZ*VZ2
4046 IF (XLOC(2,K)<YLMIN) YLMIN=XLOC(2,K)
4047 IF (XLOC(2,K)>YLMAX) YLMAX=XLOC(2,K)
4048 ENDDO
4049 YLSEC=HALF*(YLMIN+YLMAX)
4050C
4051 NSEC=0
4052 DO K=1,LENPOLY(J)
4053 KK=K+1
4054 IF (K==LENPOLY(J)) KK=1
4055 X1=XLOC(1,K)
4056 Y1=XLOC(2,K)
4057 X2=XLOC(1,KK)
4058 Y2=XLOC(2,KK)
4059 IF (Y1-Y2/=ZERO) THEN
4060 ALPHA=(YLSEC-Y2)/(Y1-Y2)
4061.AND. IF (ALPHA>=ZEROALPHA<=ONE) THEN
4062 NSEC=NSEC+1
4063 XSEC(NSEC)=ALPHA*X1+(ONE-ALPHA)*X2
4064 ENDIF
4065 ELSE
4066 IF (Y1==YLSEC) THEN
4067 NSEC=NSEC+1
4068 XSEC(NSEC)=X1
4069 NSEC=NSEC+1
4070 XSEC(NSEC)=X2
4071 ENDIF
4072 ENDIF
4073 ENDDO
4074C
4075 XSMIN1=EP30
4076 DO K=1,NSEC
4077 IF (XSEC(K)<XSMIN1) THEN
4078 XSMIN1=XSEC(K)
4079 KSMIN=K
4080 ENDIF
4081 ENDDO
4082 XSMIN2=EP30
4083 DO K=1,NSEC
4084 IF (K==KSMIN) CYCLE
4085 IF (XSEC(K)<XSMIN2) XSMIN2=XSEC(K)
4086 ENDDO
4087C
4088 XS=HALF*(XSMIN1+XSMIN2)
4089 YS=YLSEC
4090 PHOL(1,NHOL)=RPOLY(5,J)+XS*VX1+YS*VX2
4091 PHOL(2,NHOL)=RPOLY(6,J)+XS*VY1+YS*VY2
4092 PHOL(3,NHOL)=RPOLY(7,J)+XS*VZ1+YS*VZ2
4093 ENDIF
4094 ENDDO
4095C
4096 IF (INFO==0) THEN
4097 IPOLY(2,I)=LENPOLY(I)
4098 IPOLY(6+LENPOLY(I)+1,I)=NHOL
4099 DO J=1,NHOL
4100 IPOLY(6+LENPOLY(I)+1+J,I)=IADHOL(J)
4101 RPOLY(4+3*LENPOLY(I)+3*(J-1)+1,I)=PHOL(1,J)
4102 RPOLY(4+3*LENPOLY(I)+3*(J-1)+2,I)=PHOL(2,J)
4103 RPOLY(4+3*LENPOLY(I)+3*(J-1)+3,I)=PHOL(3,J)
4104 ENDDO
4105 ENDIF
4106 ENDDO
4107C
4108 RETURN
4109 END
4110C
4111!||====================================================================
4112!|| polyhedr ../engine/source/airbag/fvmesh.F
4113!||--- called by ------------------------------------------------------
4114!|| fvmesh1 ../engine/source/airbag/fvmesh.F
4115!||====================================================================
4116 SUBROUTINE POLYHEDR(IPOLY, RPOLY , POLB , NPOLB, POLH,
4117 . NPOLH, NRPMAX , NPHMAX, IBRIC, LMIN,
4118 . INFO , NPOLHMAX, NPPMAX, TOLE2)
4119C-----------------------------------------------
4120C I m p l i c i t T y p e s
4121C-----------------------------------------------
4122#include "implicit_f.inc"
4123C-----------------------------------------------
4124C D u m m y A r g u m e n t s
4125C-----------------------------------------------
4126 INTEGER NPPMAX, IPOLY(6+NPPMAX,*), POLB(*), NPOLB, NPHMAX,
4127 . POLH(NPHMAX+2,*),NPOLH, NRPMAX, IBRIC, INFO, NPOLHMAX
4128 my_real
4129 . RPOLY(NRPMAX,*), LMIN, TOLE2
4130C-----------------------------------------------
4131C L o c a l V a r i a b l e s
4132C-----------------------------------------------
4133 INTEGER I, ITAG(NPOLB), ICMAX, ICUR, II, J, JJ, K, KK, ISTOP,
4134 . L, LL, ICUR_OLD, ITY, JMIN, PMIN, POLD
4135 my_real
4136 . X1, Y1, Z1, X2, Y2, Z2, XX1, YY1, ZZ1, XX2, YY2, ZZ2,
4137 . DD11, DD12, DD21, DD22, TOLE
4138C
4139 TOLE=TOLE2*LMIN
4140C
4141 DO I=1,NPOLB
4142 ITAG(I)=0
4143 ENDDO
4144C
4145 ICMAX=0
4146 DO I=1,NPOLB
4147 IF (ITAG(I)==0) THEN
4148 ICMAX=ICMAX+1
4149 ITAG(I)=ICMAX
4150 ICUR=ICMAX
4151 ELSE
4152 ICUR=ITAG(I)
4153 ENDIF
4154 II=POLB(I)
4155 DO J=1,IPOLY(2,II)
4156 IF (J/=IPOLY(2,II)) THEN
4157 JJ=J+1
4158 ELSE
4159 JJ=1
4160 ENDIF
4161 X1=RPOLY(4+3*(J-1)+1,II)
4162 Y1=RPOLY(4+3*(J-1)+2,II)
4163 Z1=RPOLY(4+3*(J-1)+3,II)
4164 X2=RPOLY(4+3*(JJ-1)+1,II)
4165 Y2=RPOLY(4+3*(JJ-1)+2,II)
4166 Z2=RPOLY(4+3*(JJ-1)+3,II)
4167 DO K=1,NPOLB
4168 IF (K==I) CYCLE
4169 KK=POLB(K)
4170 ISTOP=0
4171 L=0
4172.AND. DO WHILE (ISTOP==0L<IPOLY(2,KK))
4173 L=L+1
4174 IF (L/=IPOLY(2,KK)) THEN
4175 LL=L+1
4176 ELSE
4177 LL=1
4178 ENDIF
4179 XX1=RPOLY(4+3*(L-1)+1,KK)
4180 YY1=RPOLY(4+3*(L-1)+2,KK)
4181 ZZ1=RPOLY(4+3*(L-1)+3,KK)
4182 XX2=RPOLY(4+3*(LL-1)+1,KK)
4183 YY2=RPOLY(4+3*(LL-1)+2,KK)
4184 ZZ2=RPOLY(4+3*(LL-1)+3,KK)
4185 DD11=(XX1-X1)**2+(YY1-Y1)**2+(ZZ1-Z1)**2
4186 DD21=(XX2-X1)**2+(YY2-Y1)**2+(ZZ2-Z1)**2
4187 DD12=(XX1-X2)**2+(YY1-Y2)**2+(ZZ1-Z2)**2
4188 DD22=(XX2-X2)**2+(YY2-Y2)**2+(ZZ2-Z2)**2
4189.AND..OR. IF ((DD11<=TOLEDD22<=TOLE)
4190.AND. . (DD21<=TOLEDD12<=TOLE)) ISTOP=L
4191 ENDDO
4192 IF (ISTOP/=0) THEN
4193 IF (ITAG(K)==0) THEN
4194 ITAG(K)=ICUR
4195 ELSE
4196 ICUR_OLD=ICUR
4197 ICUR=ITAG(K)
4198 DO L=1,NPOLB
4199 IF (ITAG(L)==ICUR_OLD) ITAG(L)=ICUR
4200 ENDDO
4201 ENDIF
4202 ENDIF
4203 ENDDO
4204 ENDDO
4205 ENDDO
4206C
4207 NPOLH=0
4208 DO I=1,ICMAX
4209 II=0
4210 DO J=1,NPOLB
4211 IF (ITAG(J)==I) II=II+1
4212 ENDDO
4213 IF (II/=0) NPOLH=NPOLH+1
4214 ENDDO
4215 IF (NPOLH>NPOLHMAX) THEN
4216 INFO=1
4217 NPOLHMAX=NPOLH
4218 RETURN
4219 ENDIF
4220C
4221 NPOLH=0
4222 DO I=1,ICMAX
4223 II=0
4224 DO J=1,NPOLB
4225 IF (ITAG(J)==I) II=II+1
4226 ENDDO
4227 IF (II/=0) THEN
4228 NPOLH=NPOLH+1
4229 POLH(1,NPOLH)=II
4230 POLH(2,NPOLH)=IBRIC
4231 II=0
4232 DO J=1,NPOLB
4233 IF (ITAG(J)==I) THEN
4234 II=II+1
4235 JJ=POLB(J)
4236 POLH(2+II,NPOLH)=JJ
4237 ITY=IPOLY(1,JJ)
4238 IF (ITY==1) THEN
4239 IPOLY(5,JJ)=NPOLH
4240 CYCLE
4241 ENDIF
4242 IF (IPOLY(5,JJ)==0) THEN
4243 IPOLY(5,JJ)=NPOLH
4244 ELSE
4245 IPOLY(6,JJ)=NPOLH
4246 ENDIF
4247 ENDIF
4248 ENDDO
4249C Tri par ordre croissant de polh
4250 DO J=1,POLH(1,NPOLH)
4251 JMIN=J
4252 PMIN=POLH(2+J,NPOLH)
4253 DO K=J+1,POLH(1,NPOLH)
4254 IF (POLH(2+K,NPOLH)<PMIN) THEN
4255 JMIN=K
4256 PMIN=POLH(2+K,NPOLH)
4257 ENDIF
4258 ENDDO
4259 POLD=POLH(2+J,NPOLH)
4260 POLH(2+J,NPOLH)=PMIN
4261 POLH(2+JMIN,NPOLH)=POLD
4262 ENDDO
4263 ENDIF
4264 ENDDO
4265C
4266 INFO=0
4267 RETURN
4268 END
4269C
4270!||====================================================================
4271!|| coorloc ../engine/source/airbag/fvmesh.F
4272!||--- called by ------------------------------------------------------
4273!|| fvmesh1 ../engine/source/airbag/fvmesh.F
4274!||====================================================================
4275 SUBROUTINE COORLOC(VPX, VPY, VPZ, V1X, V1Y,
4276 . V1Z, V2X, V2Y, V2Z, KSI,
4277 . ETA)
4278C-----------------------------------------------
4279C I m p l i c i t T y p e s
4280C-----------------------------------------------
4281#include "implicit_f.inc"
4282C-----------------------------------------------
4283C D u m m y A r g u m e n t s
4284C-----------------------------------------------
4285 my_real
4286 . VPX, VPY, VPZ, V1X, V1Y,
4287 . V1Z, V2X, V2Y, V2Z, KSI,
4288 . ETA
4289C-----------------------------------------------
4290C L o c a l V a r i a b l e s
4291C-----------------------------------------------
4292 my_real
4293 . SP1, SP2, S11, S22, S12, D
4294C
4295 SP1=VPX*V1X+VPY*V1Y+VPZ*V1Z
4296 SP2=VPX*V2X+VPY*V2Y+VPZ*V2Z
4297 S11=V1X*V1X+V1Y*V1Y+V1Z*V1Z
4298 S22=V2X*V2X+V2Y*V2Y+V2Z*V2Z
4299 S12=V1X*V2X+V1Y*V2Y+V1Z*V2Z
4300C
4301 D=S11*S22-S12*S12
4302C
4303 KSI=(SP1*S22-SP2*S12)/D
4304 ETA=(SP2*S11-SP1*S12)/D
4305C
4306 RETURN
4307 END
4308C
4309!||====================================================================
4310!|| gpolcut ../engine/source/airbag/fvmesh.F
4311!||--- called by ------------------------------------------------------
4312!|| fvmesh1 ../engine/source/airbag/fvmesh.F
4313!||====================================================================
4314 SUBROUTINE GPOLCUT(IPOLY , RPOLY , IPOLY_OLD, RPOLY_OLD , INEDGE,
4315 . RNEDGE, NBNEDGE, NX , NY , NZ ,
4316 . X0 , Y0 , Z0 , INS , RNS ,
4317 . NN , NHOL , INZ , IZ , NNS3 ,
4318 . NPOLY , NS , IELNOD , IELNOD_OLD)
4319C-----------------------------------------------
4320C I m p l i c i t T y p e s
4321C-----------------------------------------------
4322#include "implicit_f.inc"
4323C-----------------------------------------------
4324C D u m m y A r g u m e n t s
4325C-----------------------------------------------
4326 INTEGER NN, NHOL, IPOLY(6+2*NN+1+NHOL,*), IPOLY_OLD(*),
4327 . INEDGE(6,*), NBNEDGE, INS(2,*), INZ, IZ(3,*), NNS3,
4328 . NPOLY, NS, IELNOD(2*NN,*), IELNOD_OLD(*)
4329 my_real
4330 . RPOLY(4+3*2*NN+3*NHOL,*), RPOLY_OLD(*), RNEDGE(6,*), NX,
4331 . NY, NZ, X0, Y0, Z0, RNS(4,*)
4332C-----------------------------------------------
4333C L o c a l V a r i a b l e s
4334C-----------------------------------------------
4335 INTEGER NN1, I, IADHOL(NHOL+1), NSEG, ITAG(2*NN+1), II,
4336 . TSEG(3,2*NN), NHOL_OLD, ICUT, J, JJ, NSEG_INI, NSEG1,
4337 . REDIR(NN), N1, N2, ISTOP, NNP, ICLOSE, ISEG,
4338 . POLY(2*NN,NN), IN, IN1, IN2, LENPOLY(NN), K, KK,
4339 . THOL(NHOL), JN, NHOLP, IADHOLP(NHOL), KN, I1, I2,
4340 . ITAG2(2*NN), ITAGN(NN), ITAGS(NN), ISEG_OLD
4341 my_real
4342 . X1, Y1, Z1, X2, Y2, Z2, ZL1, ZL2, ALPHA, NPX, NPY, NPZ,
4343 . XP0, YP0, ZP0, VX, VY, VZ, XX, YY, ZZ, XL(NN), XLMIN,
4344 . XLC, XX1, YY1, ZZ1, XX2, YY2, ZZ2, VX1, VY1,
4345 . VZ1, VX2, VY2, VZ2, NR1, NR2, SS, VVX, VVY, VVZ,
4346 . SS1, ZL, XNS(3,NN), TOLE, LL, ZLM
4347C
4348C
4349 TOLE = ZERO
4350 TOLE = EPSILON(TOLE)
4351C
4352C Liste des segments
4353 IF (NHOL==0) THEN
4354 NN1=NN
4355 ELSE
4356 NN1=IPOLY_OLD(6+NN+1+1)-1
4357 DO I=1,NHOL
4358 IADHOL(I)=IPOLY_OLD(6+NN+1+I)
4359 ENDDO
4360 IADHOL(NHOL+1)=NN+1
4361 ENDIF
4362 NS=0
4363 NSEG=0
4364C
4365 DO I=1,2*NN
4366 ITAG(I)=0
4367 ITAG2(I)=0
4368 ENDDO
4369 ITAG(2*NN+1)=0
4370 DO I=1,NN
4371 ITAGN(I)=0
4372 ITAGS(I)=0
4373 ENDDO
4374C Segments du contour exterieur
4375 DO I=1,NN1
4376 II=I+1
4377 IF (I==NN1) II=1
4378 X1=RPOLY_OLD(4+3*(I-1)+1)
4379 Y1=RPOLY_OLD(4+3*(I-1)+2)
4380 Z1=RPOLY_OLD(4+3*(I-1)+3)
4381 X2=RPOLY_OLD(4+3*(II-1)+1)
4382 Y2=RPOLY_OLD(4+3*(II-1)+2)
4383 Z2=RPOLY_OLD(4+3*(II-1)+3)
4384 ZL1=(X1-X0)*NX+(Y1-Y0)*NY+(Z1-Z0)*NZ
4385 ZL2=(X2-X0)*NX+(Y2-Y0)*NY+(Z2-Z0)*NZ
4386 IF (ZL1-ZL2/=ZERO) THEN
4387 ALPHA=ZL2/(ZL2-ZL1)
4388.AND. IF (ALPHA>ZEROALPHA<ONE) THEN
4389 NS=NS+1
4390 INS(1,NS)=IPOLY_OLD(6+I)
4391 INS(2,NS)=IPOLY_OLD(6+II)
4392 RNS(1,NS)=ALPHA
4393 XNS(1,NS)=ALPHA*X1+(ONE-ALPHA)*X2
4394 XNS(2,NS)=ALPHA*Y1+(ONE-ALPHA)*Y2
4395 XNS(3,NS)=ALPHA*Z1+(ONE-ALPHA)*Z2
4396 NSEG=NSEG+1
4397 TSEG(1,NSEG)=I
4398 TSEG(2,NSEG)=-NS
4399 TSEG(3,NSEG)=NSEG+1
4400 NSEG=NSEG+1
4401 TSEG(1,NSEG)=-NS
4402 TSEG(2,NSEG)=II
4403 TSEG(3,NSEG)=NSEG+1
4404 ELSEIF (ALPHA==ZERO) THEN
4405 IF (ITAGN(II)==0) THEN
4406 NS=NS+1
4407 ITAGN(II)=NS
4408 INS(1,NS)=IPOLY_OLD(6+I)
4409 INS(2,NS)=IPOLY_OLD(6+II)
4410 RNS(1,NS)=ZERO
4411 XNS(1,NS)=X2
4412 XNS(2,NS)=Y2
4413 XNS(3,NS)=Z2
4414 ITAGS(NS)=1
4415 NSEG=NSEG+1
4416 TSEG(1,NSEG)=I
4417 TSEG(2,NSEG)=-NS
4418 TSEG(3,NSEG)=NSEG+1
4419 NSEG=NSEG+1
4420 TSEG(1,NSEG)=-NS
4421 TSEG(2,NSEG)=II
4422 TSEG(3,NSEG)=NSEG+1
4423 ELSE
4424 NSEG=NSEG+1
4425 TSEG(1,NSEG)=I
4426 TSEG(2,NSEG)=II
4427 TSEG(3,NSEG)=NSEG+1
4428 ENDIF
4429 ELSEIF (ALPHA==ONE) THEN
4430 IF (ITAGN(I)==0) THEN
4431 NS=NS+1
4432 ITAGN(I)=NS
4433 INS(1,NS)=IPOLY_OLD(6+I)
4434 INS(2,NS)=IPOLY_OLD(6+II)
4435 RNS(1,NS)=ONE
4436 XNS(1,NS)=X1
4437 XNS(2,NS)=Y1
4438 XNS(3,NS)=Z1
4439 ITAGS(NS)=1
4440 NSEG=NSEG+1
4441 TSEG(1,NSEG)=I
4442 TSEG(2,NSEG)=-NS
4443 TSEG(3,NSEG)=NSEG+1
4444 NSEG=NSEG+1
4445 TSEG(1,NSEG)=-NS
4446 TSEG(2,NSEG)=II
4447 TSEG(3,NSEG)=NSEG+1
4448 ELSE
4449 NSEG=NSEG+1
4450 TSEG(1,NSEG)=I
4451 TSEG(2,NSEG)=II
4452 TSEG(3,NSEG)=NSEG+1
4453 ENDIF
4454 ELSE
4455 NSEG=NSEG+1
4456 TSEG(1,NSEG)=I
4457 TSEG(2,NSEG)=II
4458 TSEG(3,NSEG)=NSEG+1
4459 ENDIF
4460 ELSE
4461 NSEG=NSEG+1
4462 TSEG(1,NSEG)=I
4463 TSEG(2,NSEG)=II
4464 TSEG(3,NSEG)=NSEG+1
4465 ENDIF
4466 ENDDO
4467 TSEG(3,NSEG)=1
4468C Segments des trous
4469 NHOL_OLD=NHOL
4470 NHOL=0
4471 DO I=1,NHOL_OLD
4472 ICUT=0
4473 NSEG_INI=NSEG
4474 DO J=IADHOL(I),IADHOL(I+1)-1
4475 JJ=J+1
4476 IF (J==(IADHOL(I+1)-1)) JJ=IADHOL(I)
4477 X1=RPOLY_OLD(4+3*(J-1)+1)
4478 Y1=RPOLY_OLD(4+3*(J-1)+2)
4479 Z1=RPOLY_OLD(4+3*(J-1)+3)
4480 X2=RPOLY_OLD(4+3*(JJ-1)+1)
4481 Y2=RPOLY_OLD(4+3*(JJ-1)+2)
4482 Z2=RPOLY_OLD(4+3*(JJ-1)+3)
4483 ZL1=(X1-X0)*NX+(Y1-Y0)*NY+(Z1-Z0)*NZ
4484 ZL2=(X2-X0)*NX+(Y2-Y0)*NY+(Z2-Z0)*NZ
4485 IF (ZL1-ZL2/=ZERO) THEN
4486 ALPHA=ZL2/(ZL2-ZL1)
4487.AND. IF (ALPHA>ZEROALPHA<ONE) THEN
4488 ICUT=1
4489 NS=NS+1
4490 INS(1,NS)=IPOLY_OLD(6+J)
4491 INS(2,NS)=IPOLY_OLD(6+JJ)
4492 RNS(1,NS)=ALPHA
4493 XNS(1,NS)=ALPHA*X1+(ONE-ALPHA)*X2
4494 XNS(2,NS)=ALPHA*Y1+(ONE-ALPHA)*Y2
4495 XNS(3,NS)=ALPHA*Z1+(ONE-ALPHA)*Z2
4496 NSEG=NSEG+1
4497 TSEG(1,NSEG)=J
4498 TSEG(2,NSEG)=-NS
4499 TSEG(3,NSEG)=NSEG+1
4500 NSEG=NSEG+1
4501 TSEG(1,NSEG)=-NS
4502 TSEG(2,NSEG)=JJ
4503 TSEG(3,NSEG)=NSEG+1
4504 ELSEIF (ALPHA==ZERO) THEN
4505 ICUT=1
4506 IF (ITAGN(II)==0) THEN
4507 NS=NS+1
4508 ITAGN(JJ)=NS
4509 INS(1,NS)=IPOLY_OLD(6+J)
4510 INS(2,NS)=IPOLY_OLD(6+JJ)
4511 RNS(1,NS)=ZERO
4512 XNS(1,NS)=X2
4513 XNS(2,NS)=Y2
4514 XNS(3,NS)=Z2
4515 ITAGS(NS)=1
4516 NSEG=NSEG+1
4517 TSEG(1,NSEG)=J
4518 TSEG(2,NSEG)=-NS
4519 TSEG(3,NSEG)=NSEG+1
4520 NSEG=NSEG+1
4521 TSEG(1,NSEG)=-NS
4522 TSEG(2,NSEG)=JJ
4523 TSEG(3,NSEG)=NSEG+1
4524 ELSE
4525 NSEG=NSEG+1
4526 TSEG(1,NSEG)=J
4527 TSEG(2,NSEG)=JJ
4528 TSEG(3,NSEG)=NSEG+1
4529 ENDIF
4530 ELSEIF (ALPHA==ONE) THEN
4531 ICUT=1
4532 IF (ITAGN(I)==0) THEN
4533 NS=NS+1
4534 ITAGN(J)=NS
4535 INS(1,NS)=IPOLY_OLD(6+J)
4536 INS(2,NS)=IPOLY_OLD(6+JJ)
4537 RNS(1,NS)=ONE
4538 XNS(1,NS)=X1
4539 XNS(2,NS)=Y1
4540 XNS(3,NS)=Z1
4541 ITAGS(NS)=1
4542 NSEG=NSEG+1
4543 TSEG(1,NSEG)=J
4544 TSEG(2,NSEG)=-NS
4545 TSEG(3,NSEG)=NSEG+1
4546 NSEG=NSEG+1
4547 TSEG(1,NSEG)=-NS
4548 TSEG(2,NSEG)=JJ
4549 TSEG(3,NSEG)=NSEG+1
4550 ELSE
4551 NSEG=NSEG+1
4552 TSEG(1,NSEG)=J
4553 TSEG(2,NSEG)=JJ
4554 TSEG(3,NSEG)=NSEG+1
4555 ENDIF
4556 ELSE
4557 NSEG=NSEG+1
4558 TSEG(1,NSEG)=J
4559 TSEG(2,NSEG)=JJ
4560 TSEG(3,NSEG)=NSEG+1
4561 ENDIF
4562 ELSE
4563 NSEG=NSEG+1
4564 TSEG(1,NSEG)=J
4565 TSEG(2,NSEG)=JJ
4566 TSEG(3,NSEG)=NSEG+1
4567 ENDIF
4568 ENDDO
4569 TSEG(3,NSEG)=NSEG_INI+1
4570C
4571 IF (ICUT==0) THEN
4572C Le trou n'est pas coupe
4573 NHOL=NHOL+1
4574 DO J=NSEG_INI+1,NSEG
4575 ITAG(J)=-NHOL
4576 ENDDO
4577 ENDIF
4578 ENDDO
4579C
4580 NSEG1=NSEG
4581C Creation des nouvelles aretes dans le plan horizontal
4582 NPX=RPOLY_OLD(2)
4583 NPY=RPOLY_OLD(3)
4584 NPZ=RPOLY_OLD(4)
4585 XP0=RPOLY_OLD(5)
4586 YP0=RPOLY_OLD(6)
4587 ZP0=RPOLY_OLD(7)
4588 VX=NY*NPZ-NZ*NPY
4589 VY=NZ*NPX-NX*NPZ
4590 VZ=NX*NPY-NY*NPX
4591 DO I=1,NS
4592 XX=XNS(1,I)
4593 YY=XNS(2,I)
4594 ZZ=XNS(3,I)
4595 XL(I)=(XX-XP0)*VX+(YY-YP0)*VY+(ZZ-ZP0)*VZ
4596 ENDDO
4597 XLMIN=EP30
4598 DO I=1,NS
4599 REDIR(I)=I
4600 ENDDO
4601 DO I=1,NS
4602 XLMIN=XL(REDIR(I))
4603 DO J=I+1,NS
4604 XLC=XL(REDIR(J))
4605 IF (XLC<XLMIN) THEN
4606 JJ=REDIR(J)
4607 REDIR(J)=REDIR(I)
4608 REDIR(I)=JJ
4609 XLMIN=XLC
4610 ENDIF
4611 ENDDO
4612 ENDDO
4613 II=0
4614 DO I=1,NS
4615 II=II+1
4616 IF (II==1) THEN
4617 N1=REDIR(I)
4618 N2=REDIR(I+1)
4619 X1=XNS(1,N1)
4620 Y1=XNS(2,N1)
4621 Z1=XNS(3,N1)
4622 X2=XNS(1,N2)
4623 Y2=XNS(2,N2)
4624 Z2=XNS(3,N2)
4625 LL=SQRT((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2)
4626C
4627 IF (LL>TOLE) THEN
4628 NSEG=NSEG+1
4629 TSEG(1,NSEG)=-N1
4630 TSEG(2,NSEG)=-N2
4631 TSEG(3,NSEG)=-1
4632 ENDIF
4633 ELSE
4634 II=0
4635 ENDIF
4636 ENDDO
4637C Nouveaux polygones
4638 ISTOP=0
4639 NPOLY=1
4640 NNP=0
4641 DO WHILE (ISTOP==0)
4642 I=1
4643.AND. DO WHILE (ITAG(I)/=0I<=NSEG)
4644 I=I+1
4645 ENDDO
4646 IF (I==NSEG+1) THEN
4647 ISTOP=1
4648 CYCLE
4649 ENDIF
4650C
4651 ICLOSE=0
4652 ISEG=I
4653 DO WHILE (ICLOSE==0)
4654 NNP=NNP+1
4655 POLY(NNP,NPOLY)=TSEG(1,ISEG)
4656 IN=TSEG(2,ISEG)
4657 IF (TSEG(3,ISEG)>0) THEN
4658 ITAG(ISEG)=1
4659 IF (IN<0) THEN
4660 ISEG_OLD=ISEG
4661 ISEG=0
4662 DO J=NSEG1+1,NSEG
4663 IF (ITAG(J)/=0) CYCLE
4664 IN1=TSEG(1,J)
4665 IN2=TSEG(2,J)
4666 IF (IN1==IN) THEN
4667 ISEG=J
4668 ELSEIF (IN2==IN) THEN
4669 ISEG=J
4670 TSEG(1,J)=IN2
4671 TSEG(2,J)=IN1
4672 ENDIF
4673 ENDDO
4674 IF (ISEG==0) ISEG=TSEG(3,ISEG_OLD)
4675 ELSE
4676 ISEG=TSEG(3,ISEG)
4677 ENDIF
4678 ELSE
4679 IF (ITAG2(ISEG)==1) ITAG(ISEG)=1
4680 ITAG2(ISEG)=1
4681 ISEG=0
4682 DO J=1,NSEG1
4683 IN1=TSEG(1,J)
4684 IF (IN1==IN) ISEG=J
4685 ENDDO
4686 ENDIF
4687C
4688 IF (ITAG(ISEG)/=0) THEN
4689 ICLOSE=1
4690 LENPOLY(NPOLY)=NNP
4691 NPOLY=NPOLY+1
4692 NNP=0
4693 ENDIF
4694 ENDDO
4695 ENDDO
4696 NPOLY=NPOLY-1
4697C Attribution des trous
4698 DO I=1,NHOL
4699 J=1
4700 DO WHILE (ITAG(J)/=-I)
4701 J=J+1
4702 ENDDO
4703 N1=TSEG(1,J)
4704 XX=RPOLY_OLD(4+3*(N1-1)+1)
4705 YY=RPOLY_OLD(4+3*(N1-1)+2)
4706 ZZ=RPOLY_OLD(4+3*(N1-1)+3)
4707 DO J=1,NPOLY
4708 ALPHA=ZERO
4709 DO K=1,LENPOLY(J)
4710 KK=K+1
4711 IF (K==LENPOLY(J)) KK=1
4712 N1=POLY(K,I)
4713 N2=POLY(KK,I)
4714 IF (N1>0) THEN
4715 XX1=RPOLY_OLD(4+3*(N1-1)+1)
4716 YY1=RPOLY_OLD(4+3*(N1-1)+2)
4717 ZZ1=RPOLY_OLD(4+3*(N1-1)+3)
4718 ELSE
4719 XX1=XNS(1,-N1)
4720 YY1=XNS(2,-N1)
4721 ZZ1=XNS(3,-N1)
4722 ENDIF
4723 IF (N2>0) THEN
4724 XX2=RPOLY_OLD(4+3*(N2-1)+1)
4725 YY2=RPOLY_OLD(4+3*(N2-1)+2)
4726 ZZ2=RPOLY_OLD(4+3*(N2-1)+3)
4727 ELSE
4728 XX2=XNS(1,-N2)
4729 YY2=XNS(2,-N2)
4730 ZZ2=XNS(3,-N2)
4731 ENDIF
4732 VX1=XX1-XX
4733 VY1=YY1-YY
4734 VZ1=ZZ1-ZZ
4735 VX2=XX2-XX
4736 VY2=YY2-YY
4737 VZ2=ZZ2-ZZ
4738 NR1=SQRT(VX1**2+VY1**2+VZ1**2)
4739 NR2=SQRT(VX2**2+VY2**2+VZ2**2)
4740 VX1=VX1/NR1
4741 VY1=VY1/NR1
4742 VZ1=VZ1/NR1
4743 VX2=VX2/NR2
4744 VY2=VY2/NR2
4745 VZ2=VZ2/NR2
4746 SS=VX1*VX2+VY1*VY2+VZ1*VZ2
4747 VVX=VY1*VZ2-VZ1*VY2
4748 VVY=VZ1*VX2-VX1*VZ2
4749 VVZ=VX1*VY2-VY1*VX2
4750 SS1=NPX*VVX+NPY*VVY+NPZ*VVZ
4751 IF (SS1>=ZERO) THEN
4752 ALPHA=ALPHA+ACOS(SS)
4753 ELSE
4754 ALPHA=ALPHA-ACOS(SS)
4755 ENDIF
4756 ENDDO
4757C
4758 IF (ABS(ALPHA)>=ONE) THOL(I)=J
4759 ENDDO
4760 ENDDO
4761C Creation des tableaux de sortie
4762 DO I=1,NS
4763 RNS(2,I)=XNS(1,I)
4764 RNS(3,I)=XNS(2,I)
4765 RNS(4,I)=XNS(3,I)
4766 ENDDO
4767C
4768 DO I=1,NPOLY
4769 IPOLY(1,I)=IPOLY_OLD(1)
4770 IPOLY(3,I)=IPOLY_OLD(3)
4771 IPOLY(4,I)=IPOLY_OLD(4)
4772 IPOLY(5,I)=IPOLY_OLD(5)
4773 IPOLY(6,I)=IPOLY_OLD(6)
4774 RPOLY(1,I)=ZERO
4775 RPOLY(2,I)=NPX
4776 RPOLY(3,I)=NPY
4777 RPOLY(4,I)=NPZ
4778 NNP=0
4779 DO J=1,LENPOLY(I)
4780 JN=POLY(J,I)
4781 IF (JN>0) THEN
4782 NNP=NNP+1
4783 IPOLY(6+NNP,I)=IPOLY_OLD(6+JN)
4784 RPOLY(4+3*(NNP-1)+1,I)=RPOLY_OLD(4+3*(JN-1)+1)
4785 RPOLY(4+3*(NNP-1)+2,I)=RPOLY_OLD(4+3*(JN-1)+2)
4786 RPOLY(4+3*(NNP-1)+3,I)=RPOLY_OLD(4+3*(JN-1)+3)
4787 IELNOD(NNP,I)=IELNOD_OLD(JN)
4788 ELSE
4789 IF (ITAGS(-JN)==0) THEN
4790 NNP=NNP+1
4791 IPOLY(6+NNP,I)=-NNS3+JN
4792 RPOLY(4+3*(NNP-1)+1,I)=XNS(1,-JN)
4793 RPOLY(4+3*(NNP-1)+2,I)=XNS(2,-JN)
4794 RPOLY(4+3*(NNP-1)+3,I)=XNS(3,-JN)
4795 IELNOD(NNP,I)=-1
4796 ELSE
4797 JJ=POLY(J+1,I)
4798 IF (J==LENPOLY(I)) JJ=POLY(1,I)
4799 X1=XNS(1,-JN)
4800 Y1=XNS(2,-JN)
4801 Z1=XNS(3,-JN)
4802 IF (JJ>0) THEN
4803 X2=RPOLY_OLD(4+3*(JJ-1)+1)
4804 Y2=RPOLY_OLD(4+3*(JJ-1)+2)
4805 Z2=RPOLY_OLD(4+3*(JJ-1)+3)
4806 ELSE
4807 X2=XNS(1,-JJ)
4808 Y2=XNS(2,-JJ)
4809 Z2=XNS(3,-JJ)
4810 ENDIF
4811 LL=SQRT((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2)
4812 IF (LL>TOLE) THEN
4813 NNP=NNP+1
4814 IPOLY(6+NNP,I)=-NNS3+JN
4815 RPOLY(4+3*(NNP-1)+1,I)=XNS(1,-JN)
4816 RPOLY(4+3*(NNP-1)+2,I)=XNS(2,-JN)
4817 RPOLY(4+3*(NNP-1)+3,I)=XNS(3,-JN)
4818 IELNOD(NNP,I)=-1
4819 ENDIF
4820 ENDIF
4821 ENDIF
4822 ENDDO
4823C
4824 NHOLP=0
4825
4826 DO J=1,NHOL
4827 IF (THOL(J)==I) THEN
4828 NHOLP=NHOLP+1
4829 IADHOLP(NHOLP)=NNP+1
4830 DO K=1,NSEG
4831 IF (TSEG(3,K)==-J) THEN
4832 NNP=NNP+1
4833 KN=TSEG(1,K)
4834 IPOLY(6+NNP,I)=KN
4835 RPOLY(4+3*(NNP-1)+1,I)=RPOLY_OLD(4+3*(KN-1)+1)
4836 RPOLY(4+3*(NNP-1)+2,I)=RPOLY_OLD(4+3*(KN-1)+2)
4837 RPOLY(4+3*(NNP-1)+3,I)=RPOLY_OLD(4+3*(KN-1)+3)
4838 ENDIF
4839 ENDDO
4840 ENDIF
4841 ENDDO
4842 IPOLY(2,I)=NNP
4843 IPOLY(6+NNP+1,I)=NHOLP
4844 DO J=1,NHOLP
4845 IPOLY(6+NNP+1+J,I)=IADHOLP(J)
4846 ENDDO
4847 ENDDO
4848C
4849 DO I=NSEG1+1,NSEG
4850 NBNEDGE=NBNEDGE+1
4851 N1=-TSEG(1,I)
4852 N2=-TSEG(2,I)
4853 INEDGE(1,NBNEDGE)=IPOLY_OLD(1)
4854 INEDGE(2,NBNEDGE)=NNS3+N1
4855 INEDGE(3,NBNEDGE)=NNS3+N2
4856 INEDGE(4,NBNEDGE)=IPOLY_OLD(3)
4857 INEDGE(5,NBNEDGE)=IPOLY_OLD(4)
4858 INEDGE(6,NBNEDGE)=INZ
4859C
4860 XX1=XNS(1,N1)
4861 YY1=XNS(2,N1)
4862 ZZ1=XNS(3,N1)
4863C
4864 XX2=XNS(1,N2)
4865 YY2=XNS(2,N2)
4866 ZZ2=XNS(3,N2)
4867C
4868 RNEDGE(1,NBNEDGE)=XX1
4869 RNEDGE(2,NBNEDGE)=YY1
4870 RNEDGE(3,NBNEDGE)=ZZ1
4871 RNEDGE(4,NBNEDGE)=XX2
4872 RNEDGE(5,NBNEDGE)=YY2
4873 RNEDGE(6,NBNEDGE)=ZZ2
4874 ENDDO
4875C
4876 DO I=1,NPOLY
4877 ZL=ZERO
4878 ZLM=ZERO
4879 DO J=1,IPOLY(2,I)
4880 XX=RPOLY(4+3*(J-1)+1,I)
4881 YY=RPOLY(4+3*(J-1)+2,I)
4882 ZZ=RPOLY(4+3*(J-1)+3,I)
4883 ZL=(XX-X0)*NX+(YY-Y0)*NY+(ZZ-Z0)*NZ
4884 IF (ABS(ZL)>ABS(ZLM)) ZLM=ZL
4885 ENDDO
4886 IZ(1,I)=1
4887 IF (ZLM>ZERO) THEN
4888 IZ(2,I)=INZ+1
4889 ELSEIF (ZLM<ZERO) THEN
4890 IZ(2,I)=INZ
4891 ENDIF
4892 ENDDO
4893C
4894 RETURN
4895 END
4896C
4897!||====================================================================
4898!|| horiedge ../engine/source/airbag/fvmesh.F
4899!||--- called by ------------------------------------------------------
4900!|| fvmesh1 ../engine/source/airbag/fvmesh.F
4901!||====================================================================
4902 SUBROUTINE HORIEDGE(IPOLY , RPOLY , NX , NY , NZ ,
4903 . NBNEDGE, INEDGE, RNEDGE, X0 , Y0 ,
4904 . Z0 , INZ , NNS3 , NREF, AREF,
4905 . NNSP )
4906C-----------------------------------------------
4907C I m p l i c i t T y p e s
4908C-----------------------------------------------
4909#include "implicit_f.inc"
4910C-----------------------------------------------
4911C D u m m y A r g u m e n t s
4912C-----------------------------------------------
4913 INTEGER IPOLY(*), NBNEDGE, INEDGE(6,*), INZ, NNS3, NREF(2,*), NNSP
4914 my_real
4915 . RPOLY(*), NX, NY, NZ, RNEDGE(6,*), X0, Y0, Z0, AREF(4,*)
4916C-----------------------------------------------
4917C L o c a l V a r i a b l e s
4918C-----------------------------------------------
4919 INTEGER NN, I, II
4920 my_real
4921 . X1, Y1, Z1, X2, Y2, Z2, ZL1, ZL2, TOLE, DD
4922C
4923* TOLE=DLAMCH('Epsmach')
4924 TOLE=EM10
4925 NN=IPOLY(2)
4926 NNSP=0
4927 DO I=1,NN
4928 II=I+1
4929 IF (I==NN) II=1
4930 X1=RPOLY(4+3*(I-1)+1)
4931 Y1=RPOLY(4+3*(I-1)+2)
4932 Z1=RPOLY(4+3*(I-1)+3)
4933 X2=RPOLY(4+3*(II-1)+1)
4934 Y2=RPOLY(4+3*(II-1)+2)
4935 Z2=RPOLY(4+3*(II-1)+3)
4936 DD=(X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2
4937 ZL1=(X1-X0)*NX+(Y1-Y0)*NY+(Z1-Z0)*NZ
4938 ZL2=(X2-X0)*NX+(Y2-Y0)*NY+(Z2-Z0)*NZ
4939.AND..AND. IF (ZL1==ZEROZL2==ZERODD>=TOLE) THEN
4940 NBNEDGE=NBNEDGE+1
4941C
4942 NNSP=NNSP+1
4943 NREF(1,NNSP)=IPOLY(6+I)
4944 NREF(2,NNSP)=IPOLY(6+II)
4945 AREF(1,NNSP)=ONE
4946 AREF(2,NNSP)=X1
4947 AREF(3,NNSP)=Y1
4948 AREF(4,NNSP)=Z1
4949 NNSP=NNSP+1
4950 NREF(1,NNSP)=IPOLY(6+I)
4951 NREF(2,NNSP)=IPOLY(6+II)
4952 AREF(1,NNSP)=ZERO
4953 AREF(2,NNSP)=X2
4954 AREF(3,NNSP)=Y2
4955 AREF(4,NNSP)=Z2
4956C
4957 INEDGE(1,NBNEDGE)=IPOLY(1)
4958 INEDGE(2,NBNEDGE)=NNS3+NNSP-1
4959 INEDGE(3,NBNEDGE)=NNS3+NNSP
4960 INEDGE(4,NBNEDGE)=IPOLY(3)
4961 INEDGE(5,NBNEDGE)=IPOLY(4)
4962 INEDGE(6,NBNEDGE)=INZ
4963C
4964 RNEDGE(1,NBNEDGE)=RPOLY(4+3*(I-1)+1)
4965 RNEDGE(2,NBNEDGE)=RPOLY(4+3*(I-1)+2)
4966 RNEDGE(3,NBNEDGE)=RPOLY(4+3*(I-1)+3)
4967 RNEDGE(4,NBNEDGE)=RPOLY(4+3*(II-1)+1)
4968 RNEDGE(5,NBNEDGE)=RPOLY(4+3*(II-1)+2)
4969 RNEDGE(6,NBNEDGE)=RPOLY(4+3*(II-1)+3)
4970 ENDIF
4971 ENDDO
4972C
4973 RETURN
4974 END
4975C
4976!||====================================================================
4977!|| horipoly ../engine/source/airbag/fvmesh.F
4978!||--- called by ------------------------------------------------------
4979!|| fvmesh1 ../engine/source/airbag/fvmesh.F
4980!||====================================================================
4981 SUBROUTINE HORIPOLY(INEDGE, RNEDGE, LEDGE , NEDGE, IPOLY,
4982 . RPOLY , IZ , IELNOD, NPOLY, NX ,
4983 . NY , NZ , INZ , IBRIC)
4984C-----------------------------------------------
4985C I m p l i c i t T y p e s
4986C-----------------------------------------------
4987#include "implicit_f.inc"
4988C-----------------------------------------------
4989C D u m m y A r g u m e n t s
4990C-----------------------------------------------
4991 INTEGER INEDGE(6,*), LEDGE(*), NEDGE, IPOLY(6+2*NEDGE+1+NEDGE,*),
4992 . IZ(3,*), IELNOD(NEDGE,*), NPOLY, INZ, IBRIC
4993 my_real
4994 . RNEDGE(6,*), RPOLY(4+6*NEDGE+3*NEDGE,*), NX, NY, NZ
4995C-----------------------------------------------
4996C L o c a l V a r i a b l e s
4997C-----------------------------------------------
4998 INTEGER NN, I, II, TNOD(2*NEDGE), TSEG(2,NEDGE), NN_OLD, JFOUND,
4999 . J, JJ, REDIR1(2*NEDGE), REDIR2(2*NEDGE), ITAG(2*NEDGE),
5000 . ITAGSEG(NEDGE+1), ISTOP, ICLOSE, N1, N2, IN, NNP,
5001 . POLY(2*NEDGE,NEDGE), ISEG, LENPOLY(NEDGE), IFOUND,
5002 . IADHOL(NEDGE), NHOL, K, KK, IPOUT, M, MM, NSEC, KSMIN,
5003 . NEDGE_OLD, TSEG_OLD(2,NEDGE)
5004 my_real
5005 . TOLE, XNOD(3,2*NEDGE), XX1, YY1, ZZ1, XX2, YY2, ZZ2,
5006 . DD, XLOC(2,NEDGE), XSEC(NEDGE), PHOL(3,NEDGE), ALPHA,
5007 . X1, Y1, Z1, VX1, VY1, VZ1, VX2, VY2, VZ2, NR1, NR2,
5008 . SS, VVX, VVY, VVZ, SS1, X2, Y2, Z2, YLMIN, YLMAX, XSMIN1,
5009 . XSMIN2, XX, YY, ZZ, YLSEC, XS, YS, LMAX, LL
5010C
5011 my_real
5012 . DLAMCH
5013 EXTERNAL DLAMCH
5014C
5015* TOLE=DLAMCH('Epsmach')
5016 TOLE=EM10
5017C Creation de la liste des noeuds
5018 NN=0
5019 LMAX=ZERO
5020 DO I=1,NEDGE
5021 II=LEDGE(I)
5022 NN=NN+1
5023 TNOD(NN)=INEDGE(2,II)
5024 XNOD(1,NN)=RNEDGE(1,II)
5025 XNOD(2,NN)=RNEDGE(2,II)
5026 XNOD(3,NN)=RNEDGE(3,II)
5027 TSEG(1,I)=NN
5028 NN=NN+1
5029 TNOD(NN)=INEDGE(3,II)
5030 XNOD(1,NN)=RNEDGE(4,II)
5031 XNOD(2,NN)=RNEDGE(5,II)
5032 XNOD(3,NN)=RNEDGE(6,II)
5033 TSEG(2,I)=NN
5034 LL=(RNEDGE(1,II)-RNEDGE(4,II))**2+
5035 . (RNEDGE(2,II)-RNEDGE(5,II))**2+
5036 . (RNEDGE(3,II)-RNEDGE(6,II))**2
5037 LMAX=MAX(LMAX,LL)
5038 ENDDO
5039* TOLE=TOLE*LMAX
5040C Elimination des noeuds doubles
5041 NN_OLD=NN
5042 NN=0
5043 DO I=1,NN_OLD
5044 XX1=XNOD(1,I)
5045 YY1=XNOD(2,I)
5046 ZZ1=XNOD(3,I)
5047 JFOUND=0
5048 DO J=1,NN
5049 JJ=REDIR1(J)
5050 XX2=XNOD(1,JJ)
5051 YY2=XNOD(2,JJ)
5052 ZZ2=XNOD(3,JJ)
5053 DD=SQRT((XX1-XX2)**2+(YY1-YY2)**2+(ZZ1-ZZ2)**2)
5054 IF (DD<=TOLE) JFOUND=J
5055 ENDDO
5056 IF (JFOUND==0) THEN
5057 NN=NN+1
5058 REDIR1(NN)=I
5059 REDIR2(I)=NN
5060 ELSE
5061 REDIR2(I)=JFOUND
5062 ENDIF
5063 ENDDO
5064C
5065 DO I=1,NEDGE
5066 N1=TSEG(1,I)
5067 N2=TSEG(2,I)
5068 TSEG(1,I)=REDIR2(N1)
5069 TSEG(2,I)=REDIR2(N2)
5070 ENDDO
5071C Elimination des segments de longueur nulle
5072 NEDGE_OLD=NEDGE
5073 NEDGE=0
5074 DO I=1,NEDGE_OLD
5075 TSEG_OLD(1,I)=TSEG(1,I)
5076 TSEG_OLD(2,I)=TSEG(2,I)
5077 ENDDO
5078 DO I=1,NEDGE_OLD
5079 IF (TSEG_OLD(1,I)/=TSEG_OLD(2,I)) THEN
5080 NEDGE=NEDGE+1
5081 TSEG(1,NEDGE)=TSEG_OLD(1,I)
5082 TSEG(2,NEDGE)=TSEG_OLD(2,I)
5083 ENDIF
5084 ENDDO
5085C Construction des polygones
5086 DO I=1,NN
5087 ITAG(I)=0
5088 ENDDO
5089 DO I=1,NEDGE+1
5090 ITAGSEG(I)=0
5091 ENDDO
5092 NPOLY=1
5093 ISTOP=0
5094 DO WHILE (ISTOP==0)
5095 I=1
5096.AND. DO WHILE (ITAGSEG(I)==1I<=NEDGE)
5097 I=I+1
5098 ENDDO
5099 IF (I==NEDGE+1) THEN
5100 ISTOP=1
5101 CYCLE
5102 ENDIF
5103C
5104 ICLOSE=0
5105 ISEG=I
5106 ITAGSEG(ISEG)=1
5107 N1=TSEG(1,ISEG)
5108 N2=TSEG(2,ISEG)
5109 ITAG(N1)=1
5110 ITAG(N2)=1
5111 IN=N2
5112 NNP=1
5113 POLY(1,NPOLY)=REDIR1(N1)
5114 DO WHILE (ICLOSE==0)
5115 IFOUND=0
5116 I=0
5117 DO WHILE (IFOUND==0)
5118 I=I+1
5119 IF (ITAGSEG(I)==1) CYCLE
5120 N1=TSEG(1,I)
5121 N2=TSEG(2,I)
5122 IF (N1==IN) THEN
5123 IFOUND=1
5124 IF (ITAG(N2)==1) ICLOSE=1
5125 ISEG=I
5126 IN=N2
5127 NNP=NNP+1
5128 POLY(NNP,NPOLY)=REDIR1(N1)
5129 ITAG(N2)=1
5130 ELSEIF (N2==IN) THEN
5131 IFOUND=1
5132 IF (ITAG(N1)==1) ICLOSE=1
5133 ISEG=I
5134 IN=N1
5135 NNP=NNP+1
5136 POLY(NNP,NPOLY)=REDIR1(N2)
5137 ITAG(N1)=1
5138 ENDIF
5139 ENDDO
5140 ITAGSEG(ISEG)=1
5141 ENDDO
5142C
5143 IF (ICLOSE==1) THEN
5144 LENPOLY(NPOLY)=NNP
5145 NPOLY=NPOLY+1
5146 ENDIF
5147 ENDDO
5148 NPOLY=NPOLY-1
5149C Creation des tableaux de sortie
5150 DO I=1,NPOLY
5151 IPOLY(1,I)=2
5152 IPOLY(2,I)=LENPOLY(I)
5153 IPOLY(3,I)=IBRIC
5154 IPOLY(4,I)=IBRIC
5155 IPOLY(5,I)=0
5156 IPOLY(6,I)=0
5157 RPOLY(1,I)=ZERO
5158 RPOLY(2,I)=NX
5159 RPOLY(3,I)=NY
5160 RPOLY(4,I)=NZ
5161 DO J=1,LENPOLY(I)
5162 JJ=POLY(J,I)
5163 IPOLY(6+J,I)=-TNOD(JJ)
5164 RPOLY(4+3*(J-1)+1,I)=XNOD(1,JJ)
5165 RPOLY(4+3*(J-1)+2,I)=XNOD(2,JJ)
5166 RPOLY(4+3*(J-1)+3,I)=XNOD(3,JJ)
5167 IELNOD(J,I)=-1
5168 ENDDO
5169 IPOLY(6+LENPOLY(I)+1,I)=0
5170C
5171 IZ(1,I)=2
5172 IZ(2,I)=INZ
5173 IZ(3,I)=INZ+1
5174 ENDDO
5175C
5176C Recherche des trous
5177 DO I=1,NPOLY
5178C
5179 NHOL=0
5180 DO J=1,NPOLY
5181 IADHOL(J)=0
5182 ENDDO
5183C
5184 DO J=1,NPOLY
5185 IF (I==J) CYCLE
5186 ALPHA=ZERO
5187 X1=RPOLY(5,J)
5188 Y1=RPOLY(6,J)
5189 Z1=RPOLY(7,J)
5190 DO K=1,LENPOLY(I)
5191 KK=K+1
5192 IF (K==LENPOLY(I)) KK=1
5193 XX1=RPOLY(4+3*(K-1)+1,I)
5194 YY1=RPOLY(4+3*(K-1)+2,I)
5195 ZZ1=RPOLY(4+3*(K-1)+3,I)
5196 XX2=RPOLY(4+3*(KK-1)+1,I)
5197 YY2=RPOLY(4+3*(KK-1)+2,I)
5198 ZZ2=RPOLY(4+3*(KK-1)+3,I)
5199 VX1=XX1-X1
5200 VY1=YY1-Y1
5201 VZ1=ZZ1-Z1
5202 VX2=XX2-X1
5203 VY2=YY2-Y1
5204 VZ2=ZZ2-Z1
5205 NR1=SQRT(VX1**2+VY1**2+VZ1**2)
5206 NR2=SQRT(VX2**2+VY2**2+VZ2**2)
5207 VX1=VX1/NR1
5208 VY1=VY1/NR1
5209 VZ1=VZ1/NR1
5210 VX2=VX2/NR2
5211 VY2=VY2/NR2
5212 VZ2=VZ2/NR2
5213 SS=VX1*VX2+VY1*VY2+VZ1*VZ2
5214 VVX=VY1*VZ2-VZ1*VY2
5215 VVY=VZ1*VX2-VX1*VZ2
5216 VVZ=VX1*VY2-VY1*VX2
5217 SS1=NX*VVX+NY*VVY+NZ*VVZ
5218 IF (SS1>=ZERO) THEN
5219 ALPHA=ALPHA+ACOS(SS)
5220 ELSE
5221 ALPHA=ALPHA-ACOS(SS)
5222 ENDIF
5223 ENDDO
5224C
5225 IF (ABS(ALPHA)>=ONE) THEN
5226C Le premier point du polygone i est a l'interieur du polygone j
5227C On teste tous les autres
5228 IPOUT=0
5229 DO K=2,LENPOLY(J)
5230 X2=RPOLY(4+3*(K-1)+1,J)
5231 Y2=RPOLY(4+3*(K-1)+2,J)
5232 Z2=RPOLY(4+3*(K-1)+3,J)
5233 ALPHA=ZERO
5234 DO M=1,LENPOLY(I)
5235 MM=M+1
5236 IF (M==LENPOLY(I)) MM=1
5237 XX1=RPOLY(4+3*(M-1)+1,I)
5238 YY1=RPOLY(4+3*(M-1)+2,I)
5239 ZZ1=RPOLY(4+3*(M-1)+3,I)
5240 XX2=RPOLY(4+3*(MM-1)+1,I)
5241 YY2=RPOLY(4+3*(MM-1)+2,I)
5242 ZZ2=RPOLY(4+3*(MM-1)+3,I)
5243 VX1=XX1-X1
5244 VY1=YY1-Y1
5245 VZ1=ZZ1-Z1
5246 VX2=XX2-X1
5247 VY2=YY2-Y1
5248 VZ2=ZZ2-Z1
5249 NR1=SQRT(VX1**2+VY1**2+VZ1**2)
5250 NR2=SQRT(VX2**2+VY2**2+VZ2**2)
5251 VX1=VX1/NR1
5252 VY1=VY1/NR1
5253 VZ1=VZ1/NR1
5254 VX2=VX2/NR2
5255 VY2=VY2/NR2
5256 VZ2=VZ2/NR2
5257 SS=VX1*VX2+VY1*VY2+VZ1*VZ2
5258 VVX=VY1*VZ2-VZ1*VY2
5259 VVY=VZ1*VX2-VX1*VZ2
5260 VVZ=VX1*VY2-VY1*VX2
5261 SS1=NX*VVX+NY*VVY+NZ*VVZ
5262 IF (SS1>=ZERO) THEN
5263 ALPHA=ALPHA+ACOS(SS)
5264 ELSE
5265 ALPHA=ALPHA-ACOS(SS)
5266 ENDIF
5267 ENDDO
5268 IF (ABS(ALPHA)<ONE) IPOUT=1
5269 ENDDO
5270C
5271 IF (IPOUT==1) CYCLE
5272C Le polygone j est un trou dans le polygone i
5273 IPOLY(1,J)=-1
5274 NHOL=NHOL+1
5275 IADHOL(NHOL)=LENPOLY(I)
5276 DO K=1,LENPOLY(J)
5277 IPOLY(6+IADHOL(NHOL)+K,I)=IPOLY(6+K,J)
5278 IELNOD(IADHOL(NHOL)+K,I)=IELNOD(K,J)
5279 RPOLY(4+3*IADHOL(NHOL)+3*(K-1)+1,I)=
5280 . RPOLY(4+3*(K-1)+1,J)
5281 RPOLY(4+3*IADHOL(NHOL)+3*(K-1)+2,I)=
5282 . RPOLY(4+3*(K-1)+2,J)
5283 RPOLY(4+3*IADHOL(NHOL)+3*(K-1)+3,I)=
5284 . RPOLY(4+3*(K-1)+3,J)
5285 ENDDO
5286 LENPOLY(I)=LENPOLY(I)+LENPOLY(J)
5287C Point interieur polygone j
5288 VX1=RPOLY(5,J)-RPOLY(8,J)
5289 VY1=RPOLY(6,J)-RPOLY(9,J)
5290 VZ1=RPOLY(7,J)-RPOLY(10,J)
5291 SS=SQRT(VX1**2+VY1**2+VZ1**2)
5292 VX1=VX1/SS
5293 VY1=VY1/SS
5294 VZ1=VZ1/SS
5295 VX2=NY*VZ1-NZ*VY1
5296 VY2=NZ*VX1-NX*VZ1
5297 VZ2=NX*VY1-NY*VX1
5298 X1=RPOLY(5,J)
5299 Y1=RPOLY(6,J)
5300 Z1=RPOLY(7,J)
5301 XLOC(1,1)=ZERO
5302 XLOC(2,1)=ZERO
5303 YLMIN=EP30
5304 YLMAX=-EP30
5305 DO K=2,LENPOLY(J)
5306 XX=RPOLY(4+3*(K-1)+1,J)
5307 YY=RPOLY(4+3*(K-1)+2,J)
5308 ZZ=RPOLY(4+3*(K-1)+3,J)
5309 VVX=XX-X1
5310 VVY=YY-Y1
5311 VVZ=ZZ-Z1
5312 XLOC(1,K)=VVX*VX1+VVY*VY1+VVZ*VZ1
5313 XLOC(2,K)=VVX*VX2+VVY*VY2+VVZ*VZ2
5314 IF (XLOC(2,K)<YLMIN) YLMIN=XLOC(2,K)
5315 IF (XLOC(2,K)>YLMAX) YLMAX=XLOC(2,K)
5316 ENDDO
5317 YLSEC=HALF*(YLMIN+YLMAX)
5318C
5319 NSEC=0
5320 DO K=1,LENPOLY(J)
5321 KK=K+1
5322 IF (K==LENPOLY(J)) KK=1
5323 X1=XLOC(1,K)
5324 Y1=XLOC(2,K)
5325 X2=XLOC(1,KK)
5326 Y2=XLOC(2,KK)
5327 IF (Y1-Y2/=ZERO) THEN
5328 ALPHA=(YLSEC-Y2)/(Y1-Y2)
5329.AND. IF (ALPHA>=ZEROALPHA<=ONE) THEN
5330 NSEC=NSEC+1
5331 XSEC(NSEC)=ALPHA*X1+(ONE-ALPHA)*X2
5332 ENDIF
5333 ELSE
5334 IF (Y1==YLSEC) THEN
5335 NSEC=NSEC+1
5336 XSEC(NSEC)=X1
5337 NSEC=NSEC+1
5338 XSEC(NSEC)=X2
5339 ENDIF
5340 ENDIF
5341 ENDDO
5342C
5343 XSMIN1=EP30
5344 DO K=1,NSEC
5345 IF (XSEC(K)<XSMIN1) THEN
5346 XSMIN1=XSEC(K)
5347 KSMIN=K
5348 ENDIF
5349 ENDDO
5350 XSMIN2=EP30
5351 DO K=1,NSEC
5352 IF (K==KSMIN) CYCLE
5353 IF (XSEC(K)<XSMIN2) XSMIN2=XSEC(K)
5354 ENDDO
5355C
5356 XS=HALF*(XSMIN1+XSMIN2)
5357 YS=YLSEC
5358 PHOL(1,NHOL)=RPOLY(5,J)+XS*VX1+YS*VX2
5359 PHOL(2,NHOL)=RPOLY(6,J)+XS*VY1+YS*VY2
5360 PHOL(3,NHOL)=RPOLY(7,J)+XS*VZ1+YS*VZ2
5361 ENDIF
5362 ENDDO
5363C
5364 IPOLY(2,I)=LENPOLY(I)
5365 IPOLY(6+LENPOLY(I)+1,I)=NHOL
5366 DO J=1,NHOL
5367 IPOLY(6+LENPOLY(I)+1+J,I)=IADHOL(J)
5368 RPOLY(4+3*LENPOLY(I)+3*(J-1)+1,I)=PHOL(1,J)
5369 RPOLY(4+3*LENPOLY(I)+3*(J-1)+2,I)=PHOL(2,J)
5370 RPOLY(4+3*LENPOLY(I)+3*(J-1)+3,I)=PHOL(3,J)
5371 ENDDO
5372 ENDDO
5373C
5374 RETURN
5375 END
5376
my_real
#define my_real
Definition cppsort.cpp:32
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
horipoly
subroutine horipoly(inedge, rnedge, ledge, nedge, ipoly, rpoly, iz, ielnod, npoly, nx, ny, nz, inz, ibric)
Definition fvmesh.F:4984
polyhedr
subroutine polyhedr(ipoly, rpoly, polb, npolb, polh, npolh, nrpmax, nphmax, ibric, lmin, info, npolhmax, nppmax, tole2)
Definition fvmesh.F:4119
horiedge
subroutine horiedge(ipoly, rpoly, nx, ny, nz, nbnedge, inedge, rnedge, x0, y0, z0, inz, nns3, nref, aref, nnsp)
Definition fvmesh.F:4906
fvmesh1
subroutine fvmesh1(ibuf, elem, x, ivolu, bric, xb, rvolu, nel, nbric, tbric, sfac, dxm, nba, nela, nna, tba, tfaca, tagels, ibufa, elema, tagela, ixs, nnf)
Definition fvmesh.F:49
facepoly
subroutine facepoly(quad, tri, ntri, ipoly, rpoly, n, normf, normt, nsmax, nnp, nrpmax, nb, nv, lmin, npolmax, nppmax, info, ielnod, xxx, elema, ibuf, nela, ibric, ifac, mvid, ilvout, ibufa, tagela, xxxa)
Definition fvmesh.F:3257
coorloc
subroutine coorloc(vpx, vpy, vpz, v1x, v1y, v1z, v2x, v2y, v2z, ksi, eta)
Definition fvmesh.F:4278
gpolcut
subroutine gpolcut(ipoly, rpoly, ipoly_old, rpoly_old, inedge, rnedge, nbnedge, nx, ny, nz, x0, y0, z0, ins, rns, nn, nhol, inz, iz, nns3, npoly, ns, ielnod, ielnod_old)
Definition fvmesh.F:4319
itribox
subroutine itribox(tri, box, norm, nverts, poly, nvmax)
Definition fvmesh.F:3107
alpha
#define alpha
Definition eval.h:35
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
fvbag_mod
Definition fvbag_mod.F:44
fvbag_mod::fvspmd
type(fvbag_spmd), dimension(:), allocatable fvspmd
Definition fvbag_mod.F:129
fvbag_mod::fvdata
type(fvbag_data), dimension(:), allocatable fvdata
Definition fvbag_mod.F:128
progbar_c
void progbar_c(int *icur, int *imax)
Definition progbar_c.c:30
spmd_fvb_gath
subroutine spmd_fvb_gath(ifv, x, xxx, xxxa, xxxsa, ido)
Definition spmd_fvb_gath.F:40
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
tritri3
subroutine tritri3(icut, fv0, fv1, fv2, fu0, fu1, fu2)
Definition fvmbags_stub.F:74
tribox3
subroutine tribox3(icut, bcenter, bhalfsize, tverts)
Definition fvmbags_stub.F:55