Download ijet.eso
Back to the list
1 : C IJET SOURCE PV 09/03/12 21:25:10 6325
2 : C IJET SOURCE PM 01/12/11 21:44:48 4041
3 : SUBROUTINE IJET
4 : CA Ph. MIRANDA
5 : CD 30/11/2001
6 : CC--------------------------------------------------------------------------
7 : CC
8 : CC Le sous-programme IJET calcule par une methode analytique exacte
9 : CC l'intersection entre des segments (connus par les coordonnees de
10 : CC leurs extremites) et les facettes triangulaires d'un maillage
11 : CC (connues par les coordonnees de leurs 3 extremites et leurs
12 : CC normales). De plus, ce programme permet de deduire les valeurs
13 : CC d'un champ appuye sur les noeuds du maillage aux points
14 : CC d'intersection des segments par interpolation.
15 : CC
16 : CC IJET reprend les fonctionnalites de la procedure GIBIANE @INTSEC
17 : CC inspiree de @INTERC concue par R.Mitteau (CEA/DSM/DRFC) et
18 : CC B.Riou (CSSI) en oct 1998.
19 : CC
20 : CC version initiale : Ph.Miranda (CSSI) en nov 2001
21 : CC modification : T.Charras (CEA/DM2S) en oct 2003
22 : CC modification : A.Moal (CSSI) en jan 2004
23 : CC
24 : CC Syntaxe generale :
25 : CC
26 : CC CHDIST MINTER CHFN CHDEP = IJET CHOLD CHNEW TOL TAB1 ;
27 : CC
28 : CC--------------------------------------------------------------------------
29 : CE En entree :
30 : CE
31 : CE CHOLD : coordonnees des points extremites initiales des segments
32 : CE (type CHPOINT a 3 composantes)
33 : CE CHNEW : coordonnees des points extremites finales des segments
34 : CE (type CHPOINT a 3 composantes appuye sur le meme support
35 : CE que CH_OLD)
36 : CE TOL : tolerance (type FLOTTANT)
37 : CE TAB1 : Table qui doit contenir les parametres suivants en entree
38 : CE
39 : CE CCOPTIO
83 : -INC SMCHPOI
84 : -INC SMCHAML
85 : -INC SMELEME
86 : -INC SMCOORD
87 : -INC CCGEOME
88 : -INC CCREEL
89 : -INC SMTABLE
90 : C
91 : SEGMENT MTRAV1
92 : REAL*8 XPN(NZ1,NBP),YPN(NZ1,NBP),ZPN(NZ1,NBP)
93 : REAL*8 XPN1(NZ1,NBP),YPN1(NZ1,NBP),ZPN1(NZ1,NBP)
94 : REAL*8 CHPAS(NZ1,NBP),CHPAS0(NZ1,NBP),CHFN(NZ1,NBP)
95 : REAL*8 CHDEX(NZ1,NBP),CHDEY(NZ1,NBP),CHDEZ(NZ1,NBP)
96 : LOGICAL INTER(NZ1,NBP)
97 : ENDSEGMENT
98 : C
99 : SEGMENT MTRAV2
100 : REAL*8 COORFAC(NZ2,NEL,3,3),TFN(NZ2,NEL,3)
101 : REAL*8 TXN(NZ2,NEL),TYN(NZ2,NEL),TZN(NZ2,NEL)
102 : ENDSEGMENT
103 : C
104 : POINTEUR CHOLD.MCHPOI,CHNEW.MCHPOI
105 : POINTEUR CHX1.MCHPOI,CHX2.MCHPOI,CHX3.MCHPOI
106 : POINTEUR CHY1.MCHPOI,CHY2.MCHPOI,CHY3.MCHPOI
107 : POINTEUR CHZ1.MCHPOI,CHZ2.MCHPOI,CHZ3.MCHPOI
108 : POINTEUR TAB1.MTABLE
109 : POINTEUR ICHOLD.MELEME
110 : POINTEUR CHCOSX.MCHAML,CHCOSY.MCHAML,CHCOSZ.MCHAML
111 : POINTEUR CHF1.MCHAML,CHF2.MCHAML,CHF3.MCHAML
112 : C
113 : CHARACTER*8 MTYPR
114 : CHARACTER*4 REP,CHARRE
115 : CHARACTER*9 MOTCLE(12)
116 : logical login,logre
117 : C
118 : C LECTURE DES OBJETS
119 : C
119 : CALL LIROBJ('CHPOINT',CHOLD,1,IRETOU)
120 : IF (IERR .NE. 0) RETURN
120 : CALL LIROBJ('CHPOINT',CHNEW,1,IRETOU)
121 : IF (IERR .NE. 0) RETURN
121 : CALL LIRREE(TOL1,1,IRETOU)
122 : IF (IERR .NE. 0) RETURN
122 : CALL LIROBJ('TABLE ',TAB1,1,IRETOU)
123 : IF (IERR .NE. 0) RETURN
124 : C
125 : C Dimensionnement des tableaux du segment MTRAV1
126 : C
127 : MCHPOI=CHOLD
128 : SEGACT MCHPOI
129 : NZ1=IPCHP(/1)
130 : DO 50 I=1,IPCHP(/1)
131 : MSOUPO=IPCHP(I)
132 : SEGACT MSOUPO
133 : MELEME=IGEOC
134 : SEGACT MELEME
135 : IF (I .EQ. 1) NBP=NUM(/2)
136 : IF (NUM(/2) .GT. NBP) NBP=NUM(/2)
137 : SEGDES MELEME
138 : SEGDES MSOUPO
139 : 50 CONTINUE
140 : SEGINI MTRAV1
141 : C
142 : C
143 : C EXTRACTION DES COORDONNEES DES POINTS Pn et Pn+1 a partir des CHPOINT
144 : C CHOLD et CHNEW
145 : C
146 : DO 100 I=1,IPCHP(/1)
147 : MSOUPO=IPCHP(I)
148 : SEGACT MSOUPO
149 : ICHOLD=IGEOC
150 : MPOVAL=IPOVAL
151 : SEGACT MPOVAL
152 : DO 200 J=1,NOCOMP(/2)
153 : IF (NOCOMP(J).EQ. 'X ')then
154 : do 331 k=1,vpocha(/1)
155 : XPN(I,K)=VPOCHA(K,J)
156 : 331 continue
157 : elseif(NOCOMP(J).EQ. 'Y ') then
158 : do 332 k=1,vpocha(/1)
159 : YPN(I,K)=VPOCHA(K,J)
160 : 332 continue
161 : elseif(NOCOMP(J).EQ. 'Z ')then
162 : do 333 k=1,vpocha(/1)
163 : ZPN(I,K)=VPOCHA(K,J)
164 : 333 continue
165 : endif
166 : 200 CONTINUE
167 : SEGDES MPOVAL
168 : SEGDES MELEME
169 : SEGDES MSOUPO
170 : 100 CONTINUE
171 : SEGDES MCHPOI
172 : C
173 : MCHPOI=CHNEW
174 : SEGACT MCHPOI
175 : DO 110 I=1,IPCHP(/1)
176 : MSOUPO=IPCHP(I)
177 : SEGACT MSOUPO
178 : MPOVAL=IPOVAL
179 : SEGACT MPOVAL
180 : DO 210 J=1,NOCOMP(/2)
181 : IF (NOCOMP(J).EQ. 'X ')then
182 : DO 310 K=1,VPOCHA(/1)
183 : XPN1(I,K)=VPOCHA(K,J)
184 : 310 CONTINUE
185 : ELSEIF (NOCOMP(J).EQ. 'Y ')then
186 : DO 311 K=1,VPOCHA(/1)
187 : YPN1(I,K)=VPOCHA(K,J)
188 : 311 CONTINUE
189 : ELSEIF (NOCOMP(J).EQ. 'Z ')then
190 : DO 312 K=1,VPOCHA(/1)
191 : ZPN1(I,K)=VPOCHA(K,J)
192 : 312 CONTINUE
193 : ENDIF
194 : 210 CONTINUE
195 : SEGDES MPOVAL
196 : SEGDES MSOUPO
197 : 110 CONTINUE
198 : SEGDES MCHPOI
199 : C
200 : MOTCLE(1) = 'ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(1),LOGIN,IOBIN,
214 : . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSX)
214 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(2),LOGIN,IOBIN,
215 : . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSY)
215 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(3),LOGIN,IOBIN,
216 : . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSZ)
217 : C
218 : MCHELM=CHCOSX
219 : SEGACT MCHELM
220 : C
221 : C Dimensionnement des tableaux du segment MTRAV2
222 : C
223 : NZ2 = ICHAML(/1)
224 : DO 60 I=1,ICHAML(/1)
225 : MCHAML=ICHAML(I)
226 : SEGACT MCHAML
227 : DO 70 IC=1,IELVAL(/1)
228 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
229 : MELVAL=IELVAL(IC)
230 : SEGACT MELVAL
231 : IF (I .EQ. 1) NEL=VELCHE(/2)
232 : IF (VELCHE(/2) .GT. NEL) NEL=VELCHE(/2)
233 : SEGDES MELVAL
234 : ENDIF
235 : 70 CONTINUE
236 : SEGDES MCHAML
237 : 60 CONTINUE
238 : SEGINI MTRAV2
239 : C
240 : C Extraction des trois cosinus directeurs (CHAMELEM) a partir de TAB1
241 : C Les elements du maillage associe sont ici des POI1
242 : C
243 : DO 120 I=1,ICHAML(/1)
244 : MCHAML=ICHAML(I)
245 : SEGACT MCHAML
246 : DO 220 IC=1,IELVAL(/1)
247 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
248 : MELVAL=IELVAL(IC)
249 : SEGACT MELVAL
250 : DO 320 IEL=1,VELCHE(/2)
251 : TXN(I,IEL) = VELCHE(1,IEL)
252 : 320 CONTINUE
253 : SEGDES MELVAL
254 : ENDIF
255 : 220 CONTINUE
256 : SEGDES MCHAML
257 : 120 CONTINUE
258 : SEGDES MCHELM
259 : C
260 : MCHELM=CHCOSY
261 : SEGACT MCHELM
262 : DO 130 I=1,ICHAML(/1)
263 : MCHAML=ICHAML(I)
264 : SEGACT MCHAML
265 : DO 230 IC=1,IELVAL(/1)
266 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
267 : MELVAL=IELVAL(IC)
268 : SEGACT MELVAL
269 : DO 330 IEL=1,VELCHE(/2)
270 : TYN(I,IEL) = VELCHE(1,IEL)
271 : 330 CONTINUE
272 : SEGDES MELVAL
273 : ENDIF
274 : 230 CONTINUE
275 : SEGDES MCHAML
276 : 130 CONTINUE
277 : SEGDES MCHELM
278 : C
279 : MCHELM=CHCOSZ
280 : SEGACT MCHELM
281 : DO 140 I=1,ICHAML(/1)
282 : MCHAML=ICHAML(I)
283 : SEGACT MCHAML
284 : DO 240 IC=1,IELVAL(/1)
285 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
286 : MELVAL=IELVAL(IC)
287 : SEGACT MELVAL
288 : DO 340 IEL=1,VELCHE(/2)
289 : TZN(I,IEL) = VELCHE(1,IEL)
290 : 340 CONTINUE
291 : SEGDES MELVAL
292 : ENDIF
293 : 240 CONTINUE
294 : SEGDES MCHAML
295 : 140 CONTINUE
296 : SEGDES MCHELM
297 : C
298 : C Extraction des coordonnees des 3 points de chaque facette
299 : C
299 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(4),LOGIN,
300 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX1)
300 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(5),LOGIN,
301 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY1)
301 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(6),LOGIN,
302 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ1)
303 : C
304 : MCHELM=CHX1
305 : SEGACT MCHELM
306 : DO 141 I=1,ICHAML(/1)
307 : MCHAML=ICHAML(I)
308 : SEGACT MCHAML
309 : DO 241 IC=1,IELVAL(/1)
310 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
311 : MELVAL=IELVAL(IC)
312 : SEGACT MELVAL
313 : DO 341 IEL=1,VELCHE(/2)
314 : COORFAC(I,IEL,1,1) = VELCHE(1,IEL)
315 : 341 CONTINUE
316 : SEGDES MELVAL
317 : ENDIF
318 : 241 CONTINUE
319 : SEGDES MCHAML
320 : 141 CONTINUE
321 : SEGDES MCHELM
322 : C
323 : MCHELM=CHY1
324 : SEGACT MCHELM
325 : DO 142 I=1,ICHAML(/1)
326 : MCHAML=ICHAML(I)
327 : SEGACT MCHAML
328 : DO 242 IC=1,IELVAL(/1)
329 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
330 : MELVAL=IELVAL(IC)
331 : SEGACT MELVAL
332 : DO 342 IEL=1,VELCHE(/2)
333 : COORFAC(I,IEL,1,2) = VELCHE(1,IEL)
334 : 342 CONTINUE
335 : SEGDES MELVAL
336 : ENDIF
337 : 242 CONTINUE
338 : SEGDES MCHAML
339 : 142 CONTINUE
340 : SEGDES MCHELM
341 : C
342 : MCHELM=CHZ1
343 : SEGACT MCHELM
344 : DO 143 I=1,ICHAML(/1)
345 : MCHAML=ICHAML(I)
346 : SEGACT MCHAML
347 : DO 243 IC=1,IELVAL(/1)
348 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
349 : MELVAL=IELVAL(IC)
350 : SEGACT MELVAL
351 : DO 343 IEL=1,VELCHE(/2)
352 : COORFAC(I,IEL,1,3) = VELCHE(1,IEL)
353 : 343 CONTINUE
354 : SEGDES MELVAL
355 : ENDIF
356 : 243 CONTINUE
357 : SEGDES MCHAML
358 : 143 CONTINUE
359 : SEGDES MCHELM
360 : C
360 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(7),LOGIN,
361 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX2)
361 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(8),LOGIN,
362 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY2)
362 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(9),LOGIN,
363 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ2)
364 : C
365 : MCHELM=CHX2
366 : SEGACT MCHELM
367 : DO 144 I=1,ICHAML(/1)
368 : MCHAML=ICHAML(I)
369 : SEGACT MCHAML
370 : DO 244 IC=1,IELVAL(/1)
371 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
372 : MELVAL=IELVAL(IC)
373 : SEGACT MELVAL
374 : DO 344 IEL=1,VELCHE(/2)
375 : COORFAC(I,IEL,2,1) = VELCHE(1,IEL)
376 : 344 CONTINUE
377 : SEGDES MELVAL
378 : ENDIF
379 : 244 CONTINUE
380 : SEGDES MCHAML
381 : 144 CONTINUE
382 : SEGDES MCHELM
383 : C
384 : MCHELM=CHY2
385 : SEGACT MCHELM
386 : DO 145 I=1,ICHAML(/1)
387 : MCHAML=ICHAML(I)
388 : SEGACT MCHAML
389 : DO 245 IC=1,IELVAL(/1)
390 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
391 : MELVAL=IELVAL(IC)
392 : SEGACT MELVAL
393 : DO 345 IEL=1,VELCHE(/2)
394 : COORFAC(I,IEL,2,2) = VELCHE(1,IEL)
395 : 345 CONTINUE
396 : SEGDES MELVAL
397 : ENDIF
398 : 245 CONTINUE
399 : SEGDES MCHAML
400 : 145 CONTINUE
401 : SEGDES MCHELM
402 : C
403 : MCHELM=CHZ2
404 : SEGACT MCHELM
405 : DO 146 I=1,ICHAML(/1)
406 : MCHAML=ICHAML(I)
407 : SEGACT MCHAML
408 : DO 246 IC=1,IELVAL(/1)
409 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
410 : MELVAL=IELVAL(IC)
411 : SEGACT MELVAL
412 : DO 346 IEL=1,VELCHE(/2)
413 : COORFAC(I,IEL,2,3) = VELCHE(1,IEL)
414 : 346 CONTINUE
415 : SEGDES MELVAL
416 : ENDIF
417 : 246 CONTINUE
418 : SEGDES MCHAML
419 : 146 CONTINUE
420 : SEGDES MCHELM
421 : C
421 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(10),LOGIN,
422 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX3)
422 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(11),LOGIN,
423 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY3)
423 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(12),LOGIN,
424 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ3)
425 : C
426 : MCHELM=CHX3
427 : SEGACT MCHELM
428 : DO 147 I=1,ICHAML(/1)
429 : MCHAML=ICHAML(I)
430 : SEGACT MCHAML
431 : DO 247 IC=1,IELVAL(/1)
432 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
433 : MELVAL=IELVAL(IC)
434 : SEGACT MELVAL
435 : DO 347 IEL=1,VELCHE(/2)
436 : COORFAC(I,IEL,3,1) = VELCHE(1,IEL)
437 : 347 CONTINUE
438 : SEGDES MELVAL
439 : ENDIF
440 : 247 CONTINUE
441 : SEGDES MCHAML
442 : 147 CONTINUE
443 : SEGDES MCHELM
444 : C
445 : MCHELM=CHY3
446 : SEGACT MCHELM
447 : DO 148 I=1,ICHAML(/1)
448 : MCHAML=ICHAML(I)
449 : SEGACT MCHAML
450 : DO 248 IC=1,IELVAL(/1)
451 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
452 : MELVAL=IELVAL(IC)
453 : SEGACT MELVAL
454 : DO 348 IEL=1,VELCHE(/2)
455 : COORFAC(I,IEL,3,2) = VELCHE(1,IEL)
456 : 348 CONTINUE
457 : SEGDES MELVAL
458 : ENDIF
459 : 248 CONTINUE
460 : SEGDES MCHAML
461 : 148 CONTINUE
462 : SEGDES MCHELM
463 : C
464 : MCHELM=CHZ3
465 : SEGACT MCHELM
466 : DO 149 I=1,ICHAML(/1)
467 : MCHAML=ICHAML(I)
468 : SEGACT MCHAML
469 : DO 249 IC=1,IELVAL(/1)
470 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN
471 : MELVAL=IELVAL(IC)
472 : SEGACT MELVAL
473 : DO 349 IEL=1,VELCHE(/2)
474 : COORFAC(I,IEL,3,3) = VELCHE(1,IEL)
475 : 349 CONTINUE
476 : SEGDES MELVAL
477 : ENDIF
478 : 249 CONTINUE
479 : SEGDES MCHAML
480 : 149 CONTINUE
481 : SEGDES MCHELM
482 : C
483 : C Lecture des flux
484 : C
485 : MTYPR = ' '
485 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,'ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,'ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,' -->
607 : C Calcul de PnPn+1 :
608 : C
609 : DEX = XPN1(IZ,K) - XPN(IZ,K)
610 : DEY = YPN1(IZ,K) - YPN(IZ,K)
611 : DEZ = ZPN1(IZ,K) - ZPN(IZ,K)
612 : C
613 : C calcul de la distance de connection par defaut
614 : C
615 : CHPAS0(IZ,K) = (DEX*DEX + DEY*DEY + DEZ*DEZ)**.5
616 : C
617 : C Test d'intersection avec le plan de la facette
618 : C
619 : IF ( (PS1*PS2 .LT. (-1*TOL1*TOL1))
620 : . .OR. (PS2 .EQ. 0.) ) THEN
621 : C
622 : C -> --> ->
623 : C Calcul de AD1 = PnPn+1 . N :
624 : C
625 : AD1 = DEX*TXN(I,J) + DEY*TYN(I,J) + DEZ*TZN(I,J)
626 : C
627 : C Test de detection des lignes de champ paralleles a la facette
628 : C
629 : IF (ABS(AD1) .GT. TOL1) THEN
630 : C
631 : C
632 : C Calcul des points d'intersection M entre les lignes de champ et
633 : C le plan de la facette
634 : C
635 : XM = ( (XA1*DEX*TXN(I,J)) -
636 : . ((((YPN(IZ,K)-YA1)*DEX)-
637 : . (XPN(IZ,K)*DEY))*TYN(I,J)) -
638 : . ((((ZPN(IZ,K)-ZA1)*DEX)-
639 : . (XPN(IZ,K)*DEZ))*TZN(I,J)) ) / AD1
640 : C
641 : YM = ( (YA1*DEY*TYN(I,J)) -
642 : . ((((ZPN(IZ,K)-ZA1)*DEY)-
643 : . (YPN(IZ,K)*DEZ))*TZN(I,J)) -
644 : . ((((XPN(IZ,K)-XA1)*DEY)-
645 : . (YPN(IZ,K)*DEX))*TXN(I,J)) ) / AD1
646 : C
647 : ZM = ( (ZA1*DEZ*TZN(I,J)) -
648 : . ((((XPN(IZ,K)-XA1)*DEZ)-
649 : . (ZPN(IZ,K)*DEX))*TXN(I,J)) -
650 : . ((((YPN(IZ,K)-YA1)*DEZ)-
651 : . (ZPN(IZ,K)*DEY))*TYN(I,J)) ) / AD1
652 : C
653 : C Calcul des vecteurs AM, BM, CM
654 : C
655 : XAM = XM - XA1
656 : XBM = XM - XB1
657 : XCM = XM - XC1
658 : C
659 : C
660 : YAM = YM - YA1
661 : YBM = YM - YB1
662 : YCM = YM - YC1
663 : C
664 : ZAM = ZM - ZA1
665 : ZBM = ZM - ZB1
666 : ZCM = ZM - ZC1
667 : C
668 : C Denominateurs
669 : C
670 : DX = (YCM*ZBM)-(ZCM*YBM)+(ZAM*YBM)-
671 : . (ZAM*YCM)-(YAM*ZBM)+(YAM*ZCM)
672 : C
673 : DY = (ZCM*XBM)-(XCM*ZBM)+(XAM*ZBM)-
674 : . (XAM*ZCM)-(ZAM*XBM)+(ZAM*XCM)
675 : C
676 : DZ = (YCM*XBM)-(XCM*YBM)+(XAM*YBM)-
677 : . (XAM*YCM)-(YAM*XBM)+(YAM*XCM)
678 : C
679 : IF (ABS(DZ) .GT. TOL1) THEN
680 : D1 = DZ
681 : A1 = YCM*XBM-XCM*YBM
682 : B1 = YAM*XCM-XAM*YCM
683 : C1 = YBM*XAM-XBM*YAM
684 : ELSEIF (ABS(DY) .GT. TOL1) THEN
685 : D1 = DY
686 : A1 = ZCM*XBM-XCM*ZBM
687 : B1 = ZAM*XCM-XAM*ZCM
688 : C1 = ZBM*XAM-XBM*ZAM
689 : ELSE
690 : D1 = DX
691 : A1 = YCM*ZBM-ZCM*YBM
692 : B1 = YAM*ZCM-ZAM*YCM
693 : C1 = YBM*ZAM-ZBM*YAM
694 : ENDIF
695 : C
696 : C Coordonnees barycentriques
697 : C
698 : ALPHA = A1 / D1
699 : BETA = B1 / D1
700 : GAMMA = C1 / D1
701 : C
702 : IF ( (ALPHA .GE. 0.) .AND.
703 : . (BETA .GE. 0.) .AND.
704 : . (GAMMA .GE. 0.) ) THEN
705 : C
706 : INTER(IZ,K)=.TRUE.
707 : C
708 : C
709 : C Calcul du Flux Normalise
710 : C
711 : CHFN(IZ,K) = TFN(I,J,1)*ALPHA +
712 : . TFN(I,J,2)*BETA +
713 : . TFN(I,J,3)*GAMMA
714 : C
715 : C Calcul des champs de deplacement :
716 : C
717 : CHDEX(IZ,K) = XPN(IZ,K)-XM
718 : CHDEY(IZ,K) = YPN(IZ,K)-YM
719 : CHDEZ(IZ,K) = ZPN(IZ,K)-ZM
720 :
721 : C
722 : C Calcul de d(Pn,M) :
723 : C
724 : CHPAS(IZ,K) = ((XPN(IZ,K)-XM)**2. +
725 : . (YPN(IZ,K)-YM)**2. + (ZPN(IZ,K)-ZM)**2.)**.5
726 : ENDIF
727 : ENDIF
728 : ENDIF
729 : ENDIF
730 : 600 CONTINUE
731 : 550 CONTINUE
732 : 500 CONTINUE
733 : SEGDES MELVAL
734 : ENDIF
735 : 450 CONTINUE
736 : SEGDES MCHAML
737 : 400 CONTINUE
738 : SEGDES MCHELM
739 : C
740 : C--------------------------------------------------------
741 : C
742 : C Creation du maillage MINTER des points d'intersection
743 : C
744 : NBNN = 1
745 : NBELEM = NBP
746 : NBSOUS = 0
747 : NBREF = 0
748 : SEGINI MELEME
749 : MINTER = MELEME
750 : ITYPEL = 1
751 : C
752 : C Construction de MINTER
753 : C
754 : IPT1 = ICHOLD
755 : SEGACT IPT1
756 : NINTER = 0
757 : DO 701 I=1,NZ1
758 : DO 700 K=1,NBP
759 : IF (INTER(I,K)) THEN
760 : NINTER = NINTER+1
761 : NUM(1,NINTER) = IPT1.NUM(1,K)
762 : ENDIF
763 : 700 CONTINUE
764 : 701 CONTINUE
765 : NBELEM = NINTER
766 : SEGADJ MELEME
767 : SEGDES MELEME,IPT1
768 : C--------------------------------------------------------
769 : C
770 : C Creation du CHPOINT CHDIST
771 : C
772 : C segment MCHPOI
773 : NAT = 1
774 : NSOUPO = NZ1
775 : SEGINI MCHPOI
776 : ICHDIS = MCHPOI
777 : IFOPOI = 2
778 : JATTRI(1) = 2
779 : C segment MSOUPO
780 : NC = 1
781 : DO 901 I=1,NZ1
782 : SEGINI MSOUPO
783 : IPCHP(I)=MSOUPO
784 : NOCOMP(1)= 'SCAL'
785 : C segment MELEME : maillage associe a CHDIST
786 : NBNN = 1
787 : NBELEM = NBP
788 : NBSOUS = 0
789 : NBREF = 0
790 : C
791 : C LE CHAMPOINT CHDIST S'APPUIE SUR LE MEME MAILLAGE QUE CHOLD
792 : C
793 : IGEOC=ICHOLD
794 : C
795 : C Construction de MPOVAL
796 : C
797 : N = NBP
798 : SEGINI MPOVAL
799 : IPOVAL=MPOVAL
800 : C
801 : C On met la valeur de la distance de connection dans le chpoint CHDIST
802 : C Ce point n'existera plus dans le prochain maillage MINTER
803 : C
804 : DO 900 K=1,NBP
805 : IF (INTER(I,K)) THEN
806 : VPOCHA(K,1)=CHPAS(I,K)
807 : ELSE
808 : VPOCHA(K,1)=CHPAS0(I,K)
809 : ENDIF
810 : 900 CONTINUE
811 : C
812 : SEGDES MPOVAL
813 : SEGDES MSOUPO
814 : 901 CONTINUE
815 : SEGDES MCHPOI
816 : C
817 : C--------------------------------------------------------
818 : C
819 : C Creation du CHPOINT CHFN
820 : C
821 : C segment MCHPOI
822 : NAT = 1
823 : NSOUPO = NZ1
824 : SEGINI MCHPOI
825 : ICHFN = MCHPOI
826 : IFOPOI = 2
827 : JATTRI(1)=2
828 : C segment MSOUPO
829 : NC = 1
830 : DO 911 I=1,NZ1
831 : SEGINI MSOUPO
832 : IPCHP(I)=MSOUPO
833 : NOCOMP(1)= 'SCAL'
834 : C segment MELEME : maillage associe a CHDIST
835 : NBNN = 1
836 : NBELEM = NBP
837 : NBSOUS = 0
838 : NBREF = 0
839 : C
840 : C LE CHAMPOINT CHFN S'APPUIE SUR LE MEME MAILLAGE QUE CHOLD
841 : C
842 : IGEOC=ICHOLD
843 : C
844 : C Construction de MPOVAL
845 : C
846 : N = NBP
847 : SEGINI MPOVAL
848 : IPOVAL=MPOVAL
849 : C
850 : C On met la valeur de la distance de connection dans le chpoint CHDIST
851 : C Ce point n'existera plus dans le prochain maillage MINTER
852 : C
853 : DO 910 K=1,NBP
854 : IF (INTER(I,K)) THEN
855 : VPOCHA(K,1)=CHFN(I,K)
856 : ELSE
857 : VPOCHA(K,1)=0.
858 : ENDIF
859 : 910 CONTINUE
860 : C
861 : C
862 : C Desactivation des segments
863 : C
864 : SEGDES MPOVAL
865 : SEGDES MSOUPO
866 : 911 CONTINUE
867 : SEGDES MCHPOI
868 : C--------------------------------------------------------
869 : C
870 : C Creation du CHPOINT CHDEP
871 : C
872 : C segment MCHPOI
873 : NAT = 1
874 : NSOUPO = 1
875 : SEGINI MCHPOI
876 : ICHDEP = MCHPOI
877 : IFOPOI = 2
878 : JATTRI(1) = 1
879 : C segment MSOUPO
880 : NC = 3
881 : SEGINI MSOUPO
882 : IPCHP(1)=MSOUPO
883 : NOCOMP(1)= 'UX '
884 : NOCOMP(2)= 'UY '
885 : NOCOMP(3)= 'UZ '
886 : C segment MELEME : maillage associe a CHDIST
887 : NBNN = 1
888 : NBELEM = NBP
889 : NBSOUS = 0
890 : NBREF = 0
891 : C
892 : C LE CHAMPOINT CHDEP S'APPUIE SUR LE MEME MAILLAGE QUE MINTER
893 : C
894 : IGEOC=MINTER
895 : C
896 : C Construction de MPOVAL
897 : C
898 : N = NINTER
899 : SEGINI MPOVAL
900 : IPOVAL=MPOVAL
901 : C
902 : NINTER = 0
903 : C
904 : C On met la valeur du champ de deplacement dans le chpoint CHDEP
905 : C
906 : DO 921 I=1,NZ1
907 : DO 920 K=1,NBP
908 : IF (INTER(I,K)) THEN
909 : NINTER = NINTER+1
910 : VPOCHA(NINTER,1)= 0. - CHDEX(I,K)
911 : VPOCHA(NINTER,2)= 0. - CHDEY(I,K)
912 : VPOCHA(NINTER,3)= 0. - CHDEZ(I,K)
913 : ENDIF
914 : 920 CONTINUE
915 : 921 CONTINUE
916 : C
917 : C
918 : C Desactivation des segments
919 : C
920 : SEGDES MPOVAL
921 : SEGDES MSOUPO
922 : SEGDES MCHPOI
923 : C--------------------------------------------------------
924 : C
925 : C Ecriture des nouveaux objets en sortie
926 : C
926 : CALL ECROBJ('CHPOINT ',ICHDEP)
926 : CALL ECROBJ('CHPOINT ',ICHFN)
927 : C
927 : CALL ECROBJ('MAILLAGE',MINTER)
928 : C
928 : CALL ECROBJ('CHPOINT ',ICHDIS)
929 : C
930 : SEGSUP MTRAV1
931 : SEGSUP MTRAV2
932 : C
933 : RETURN
934 : END
935 :
936 :
937 :
938 :
939 :
940 :
941 :