1 : C ITRC SOURCE PV 09/03/12 21:25:37 6325 2 : SUBROUTINE ITRC 3 : CA Ph. MIRANDA 4 : CD 30/11/2001 5 : CC-------------------------------------------------------------------------- 6 : CC 7 : CC Le sous-programme ITRC calcule par une methode analytique exacte 8 : CC l'intersection entre des segments (connus par les coordonnees de 9 : CC leurs extremites) et les facettes triangulaires d'un maillage 10 : CC (connues par les coordonnees de leurs 3 extremites et leurs 11 : CC normales). 12 : CC 13 : CC ITRC reprend les fonctionnalites de la procedure GIBIANE @INTERC 14 : CC concue par R.Mitteau (CEA/DSM/DRFC) et B.Riou (CSSI) en oct 1998. 15 : CC 16 : CC version initiale : Ph.Miranda (CSSI) en nov 2001 17 : CC modification : T.Charras (CEA/DM2S) en oct 2003 18 : CC modification : A.Moal (CSSI) en jan 2004 19 : CC 20 : CC Syntaxe generale : 21 : CC 22 : CC CHDIST MINTER = ITRC CHOLD CHNEW TOL TAB1 ; 23 : CC 24 : CC-------------------------------------------------------------------------- 25 : CE En entree : 26 : CE 27 : CE CHOLD : coordonnees des points extremites initiales des segments 28 : CE (type CHPOINT a 3 composantes) 29 : CE CHNEW : coordonnees des points extremites finales des segments 30 : CE (type CHPOINT a 3 composantes appuye sur le meme support 31 : CE que CH_OLD) 32 : CE TOL : tolerance (type FLOTTANT) 33 : CE TAB1 : Table qui doit contenir les parametres suivants en entree 34 : CE 35 : CECCOPTIO 70 : -INC SMCHPOI 71 : -INC SMCHAML 72 : -INC SMELEME 73 : -INC SMCOORD 74 : -INC CCGEOME 75 : -INC CCREEL 76 : -INC SMTABLE 77 : C 78 : SEGMENT MTRAV1 79 : REAL*8 XPN(NZ1,NBP),YPN(NZ1,NBP),ZPN(NZ1,NBP) 80 : REAL*8 XPN1(NZ1,NBP),YPN1(NZ1,NBP),ZPN1(NZ1,NBP) 81 : REAL*8 CHPAS(NZ1,NBP),CHPAS0(NZ1,NBP) 82 : LOGICAL INTER(NZ1,NBP) 83 : ENDSEGMENT 84 : C 85 : SEGMENT MTRAV2 86 : REAL*8 COORFAC(NZ2,NEL,3,3) 87 : REAL*8 TXN(NZ2,NEL),TYN(NZ2,NEL),TZN(NZ2,NEL) 88 : ENDSEGMENT 89 : C 90 : POINTEUR CHOLD.MCHPOI,CHNEW.MCHPOI 91 : POINTEUR CHX1.MCHPOI,CHX2.MCHPOI,CHX3.MCHPOI 92 : POINTEUR CHY1.MCHPOI,CHY2.MCHPOI,CHY3.MCHPOI 93 : POINTEUR CHZ1.MCHPOI,CHZ2.MCHPOI,CHZ3.MCHPOI 94 : POINTEUR TAB1.MTABLE 95 : POINTEUR ICHOLD.MELEME 96 : POINTEUR CHCOSX.MCHAML,CHCOSY.MCHAML,CHCOSZ.MCHAML 97 : C 98 : CHARACTER*8 MTYPR 99 : CHARACTER*4 REP 100 : CHARACTER*9 MOTCLE(12) 101 : logical login,logre 102 : character*4 charre 103 : C 104 : C LECTURE DES OBJETS 105 : C 105 : CALL LIROBJ('CHPOINT',CHOLD,1,IRETOU) 106 : IF (IERR .NE. 0) RETURN 106 : CALL LIROBJ('CHPOINT',CHNEW,1,IRETOU) 107 : IF (IERR .NE. 0) RETURN 107 : CALL LIRREE(TOL1,1,IRETOU) 108 : IF (IERR .NE. 0) RETURN 108 : CALL LIROBJ('TABLE ',TAB1,1,IRETOU) 109 : IF (IERR .NE. 0) RETURN 110 : C 111 : C Dimensionnement des tableaux du segment MTRAV1 112 : C 113 : MCHPOI=CHOLD 114 : SEGACT MCHPOI 115 : NZ1=IPCHP(/1) 116 : DO 50 I=1,IPCHP(/1) 117 : MSOUPO=IPCHP(I) 118 : SEGACT MSOUPO 119 : MELEME=IGEOC 120 : SEGACT MELEME 121 : IF (I .EQ. 1) NBP=NUM(/2) 122 : IF (NUM(/2) .GT. NBP) NBP=NUM(/2) 123 : SEGDES MELEME 124 : SEGDES MSOUPO 125 : 50 CONTINUE 126 : SEGINI MTRAV1 127 : C 128 : C 129 : C EXTRACTION DES COORDONNEES DES POINTS Pn et Pn+1 a partir des CHPOINT 130 : C CHOLD et CHNEW 131 : C 132 : DO 100 I=1,IPCHP(/1) 133 : MSOUPO=IPCHP(I) 134 : SEGACT MSOUPO 135 : ICHOLD=IGEOC 136 : MPOVAL=IPOVAL 137 : SEGACT MPOVAL 138 : DO 200 J=1,NOCOMP(/2) 139 : IF (NOCOMP(J).EQ. 'X ')then 140 : do 331 k=1,vpocha(/1) 141 : XPN(I,K)=VPOCHA(K,J) 142 : 331 continue 143 : elseif(NOCOMP(J).EQ. 'Y ') then 144 : do 332 k=1,vpocha(/1) 145 : YPN(I,K)=VPOCHA(K,J) 146 : 332 continue 147 : elseif(NOCOMP(J).EQ. 'Z ')then 148 : do 333 k=1,vpocha(/1) 149 : ZPN(I,K)=VPOCHA(K,J) 150 : 333 continue 151 : endif 152 : 200 CONTINUE 153 : SEGDES MPOVAL 154 : SEGDES MELEME 155 : SEGDES MSOUPO 156 : 100 CONTINUE 157 : SEGDES MCHPOI 158 : C 159 : MCHPOI=CHNEW 160 : SEGACT MCHPOI 161 : DO 110 I=1,IPCHP(/1) 162 : MSOUPO=IPCHP(I) 163 : SEGACT MSOUPO 164 : MPOVAL=IPOVAL 165 : SEGACT MPOVAL 166 : DO 210 J=1,NOCOMP(/2) 167 : IF (NOCOMP(J).EQ. 'X ')then 168 : DO 310 K=1,VPOCHA(/1) 169 : XPN1(I,K)=VPOCHA(K,J) 170 : 310 CONTINUE 171 : ELSEIF (NOCOMP(J).EQ. 'Y ')then 172 : DO 311 K=1,VPOCHA(/1) 173 : YPN1(I,K)=VPOCHA(K,J) 174 : 311 CONTINUE 175 : ELSEIF (NOCOMP(J).EQ. 'Z ')then 176 : DO 312 K=1,VPOCHA(/1) 177 : ZPN1(I,K)=VPOCHA(K,J) 178 : 312 CONTINUE 179 : ENDIF 180 : 210 CONTINUE 181 : SEGDES MPOVAL 182 : SEGDES MSOUPO 183 : 110 CONTINUE 184 : SEGDES MCHPOI 185 : C 186 : MOTCLE(1) = ' ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(1),LOGIN,IOBIN, 200 : . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSX) 200 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(2),LOGIN,IOBIN, 201 : . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSY) 201 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(3),LOGIN,IOBIN, 202 : . 'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHCOSZ) 203 : C 204 : MCHELM=CHCOSX 205 : SEGACT MCHELM 206 : C 207 : C Dimensionnement des tableaux du segment MTRAV2 208 : C 209 : NZ2 = ICHAML(/1) 210 : DO 60 I=1,ICHAML(/1) 211 : MCHAML=ICHAML(I) 212 : SEGACT MCHAML 213 : DO 70 IC=1,IELVAL(/1) 214 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 215 : MELVAL=IELVAL(IC) 216 : SEGACT MELVAL 217 : IF (I .EQ. 1) NEL=VELCHE(/2) 218 : IF (VELCHE(/2) .GT. NEL) NEL=VELCHE(/2) 219 : SEGDES MELVAL 220 : ENDIF 221 : 70 CONTINUE 222 : SEGDES MCHAML 223 : 60 CONTINUE 224 : SEGINI MTRAV2 225 : C 226 : C Extraction des trois cosinus directeurs (CHAMELEM) a partir de TAB1 227 : C Les elements du maillage associe sont ici des POI1 228 : C 229 : DO 120 I=1,ICHAML(/1) 230 : MCHAML=ICHAML(I) 231 : SEGACT MCHAML 232 : DO 220 IC=1,IELVAL(/1) 233 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 234 : MELVAL=IELVAL(IC) 235 : SEGACT MELVAL 236 : DO 320 IEL=1,VELCHE(/2) 237 : TXN(I,IEL) = VELCHE(1,IEL) 238 : 320 CONTINUE 239 : SEGDES MELVAL 240 : ENDIF 241 : 220 CONTINUE 242 : SEGDES MCHAML 243 : 120 CONTINUE 244 : SEGDES MCHELM 245 : C 246 : MCHELM=CHCOSY 247 : SEGACT MCHELM 248 : DO 130 I=1,ICHAML(/1) 249 : MCHAML=ICHAML(I) 250 : SEGACT MCHAML 251 : DO 230 IC=1,IELVAL(/1) 252 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 253 : MELVAL=IELVAL(IC) 254 : SEGACT MELVAL 255 : DO 330 IEL=1,VELCHE(/2) 256 : TYN(I,IEL) = VELCHE(1,IEL) 257 : 330 CONTINUE 258 : SEGDES MELVAL 259 : ENDIF 260 : 230 CONTINUE 261 : SEGDES MCHAML 262 : 130 CONTINUE 263 : SEGDES MCHELM 264 : C 265 : MCHELM=CHCOSZ 266 : SEGACT MCHELM 267 : DO 140 I=1,ICHAML(/1) 268 : MCHAML=ICHAML(I) 269 : SEGACT MCHAML 270 : DO 240 IC=1,IELVAL(/1) 271 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 272 : MELVAL=IELVAL(IC) 273 : SEGACT MELVAL 274 : DO 340 IEL=1,VELCHE(/2) 275 : TZN(I,IEL) = VELCHE(1,IEL) 276 : 340 CONTINUE 277 : SEGDES MELVAL 278 : ENDIF 279 : 240 CONTINUE 280 : SEGDES MCHAML 281 : 140 CONTINUE 282 : SEGDES MCHELM 283 : C 284 : C Extraction des coordonnees des 3 points de chaque facette 285 : C 285 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(4),LOGIN, 286 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX1) 286 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(5),LOGIN, 287 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY1) 287 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(6),LOGIN, 288 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ1) 289 : C 290 : MCHELM=CHX1 291 : SEGACT MCHELM 292 : DO 141 I=1,ICHAML(/1) 293 : MCHAML=ICHAML(I) 294 : SEGACT MCHAML 295 : DO 241 IC=1,IELVAL(/1) 296 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 297 : MELVAL=IELVAL(IC) 298 : SEGACT MELVAL 299 : DO 341 IEL=1,VELCHE(/2) 300 : COORFAC(I,IEL,1,1) = VELCHE(1,IEL) 301 : 341 CONTINUE 302 : SEGDES MELVAL 303 : ENDIF 304 : 241 CONTINUE 305 : SEGDES MCHAML 306 : 141 CONTINUE 307 : SEGDES MCHELM 308 : C 309 : MCHELM=CHY1 310 : SEGACT MCHELM 311 : DO 142 I=1,ICHAML(/1) 312 : MCHAML=ICHAML(I) 313 : SEGACT MCHAML 314 : DO 242 IC=1,IELVAL(/1) 315 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 316 : MELVAL=IELVAL(IC) 317 : SEGACT MELVAL 318 : DO 342 IEL=1,VELCHE(/2) 319 : COORFAC(I,IEL,1,2) = VELCHE(1,IEL) 320 : 342 CONTINUE 321 : SEGDES MELVAL 322 : ENDIF 323 : 242 CONTINUE 324 : SEGDES MCHAML 325 : 142 CONTINUE 326 : SEGDES MCHELM 327 : C 328 : MCHELM=CHZ1 329 : SEGACT MCHELM 330 : DO 143 I=1,ICHAML(/1) 331 : MCHAML=ICHAML(I) 332 : SEGACT MCHAML 333 : DO 243 IC=1,IELVAL(/1) 334 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 335 : MELVAL=IELVAL(IC) 336 : SEGACT MELVAL 337 : DO 343 IEL=1,VELCHE(/2) 338 : COORFAC(I,IEL,1,3) = VELCHE(1,IEL) 339 : 343 CONTINUE 340 : SEGDES MELVAL 341 : ENDIF 342 : 243 CONTINUE 343 : SEGDES MCHAML 344 : 143 CONTINUE 345 : SEGDES MCHELM 346 : C 346 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(7),LOGIN, 347 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX2) 347 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(8),LOGIN, 348 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY2) 348 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(9),LOGIN, 349 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ2) 350 : C 351 : MCHELM=CHX2 352 : SEGACT MCHELM 353 : DO 144 I=1,ICHAML(/1) 354 : MCHAML=ICHAML(I) 355 : SEGACT MCHAML 356 : DO 244 IC=1,IELVAL(/1) 357 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 358 : MELVAL=IELVAL(IC) 359 : SEGACT MELVAL 360 : DO 344 IEL=1,VELCHE(/2) 361 : COORFAC(I,IEL,2,1) = VELCHE(1,IEL) 362 : 344 CONTINUE 363 : SEGDES MELVAL 364 : ENDIF 365 : 244 CONTINUE 366 : SEGDES MCHAML 367 : 144 CONTINUE 368 : SEGDES MCHELM 369 : C 370 : MCHELM=CHY2 371 : SEGACT MCHELM 372 : DO 145 I=1,ICHAML(/1) 373 : MCHAML=ICHAML(I) 374 : SEGACT MCHAML 375 : DO 245 IC=1,IELVAL(/1) 376 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 377 : MELVAL=IELVAL(IC) 378 : SEGACT MELVAL 379 : DO 345 IEL=1,VELCHE(/2) 380 : COORFAC(I,IEL,2,2) = VELCHE(1,IEL) 381 : 345 CONTINUE 382 : SEGDES MELVAL 383 : ENDIF 384 : 245 CONTINUE 385 : SEGDES MCHAML 386 : 145 CONTINUE 387 : SEGDES MCHELM 388 : C 389 : MCHELM=CHZ2 390 : SEGACT MCHELM 391 : DO 146 I=1,ICHAML(/1) 392 : MCHAML=ICHAML(I) 393 : SEGACT MCHAML 394 : DO 246 IC=1,IELVAL(/1) 395 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 396 : MELVAL=IELVAL(IC) 397 : SEGACT MELVAL 398 : DO 346 IEL=1,VELCHE(/2) 399 : COORFAC(I,IEL,2,3) = VELCHE(1,IEL) 400 : 346 CONTINUE 401 : SEGDES MELVAL 402 : ENDIF 403 : 246 CONTINUE 404 : SEGDES MCHAML 405 : 146 CONTINUE 406 : SEGDES MCHELM 407 : C 407 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(10),LOGIN, 408 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHX3) 408 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(11),LOGIN, 409 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHY3) 409 : CALL ACCTAB(TAB1,'MOT ',IVALIN,XVALIN,MOTCLE(12),LOGIN, 410 : . IOBIN,'MCHAML ',IVALRE,XVALRE,CHARRE,LOGRE,CHZ3) 411 : C 412 : MCHELM=CHX3 413 : SEGACT MCHELM 414 : DO 147 I=1,ICHAML(/1) 415 : MCHAML=ICHAML(I) 416 : SEGACT MCHAML 417 : DO 247 IC=1,IELVAL(/1) 418 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 419 : MELVAL=IELVAL(IC) 420 : SEGACT MELVAL 421 : DO 347 IEL=1,VELCHE(/2) 422 : COORFAC(I,IEL,3,1) = VELCHE(1,IEL) 423 : 347 CONTINUE 424 : SEGDES MELVAL 425 : ENDIF 426 : 247 CONTINUE 427 : SEGDES MCHAML 428 : 147 CONTINUE 429 : SEGDES MCHELM 430 : C 431 : MCHELM=CHY3 432 : SEGACT MCHELM 433 : DO 148 I=1,ICHAML(/1) 434 : MCHAML=ICHAML(I) 435 : SEGACT MCHAML 436 : DO 248 IC=1,IELVAL(/1) 437 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 438 : MELVAL=IELVAL(IC) 439 : SEGACT MELVAL 440 : DO 348 IEL=1,VELCHE(/2) 441 : COORFAC(I,IEL,3,2) = VELCHE(1,IEL) 442 : 348 CONTINUE 443 : SEGDES MELVAL 444 : ENDIF 445 : 248 CONTINUE 446 : SEGDES MCHAML 447 : 148 CONTINUE 448 : SEGDES MCHELM 449 : C 450 : MCHELM=CHZ3 451 : SEGACT MCHELM 452 : DO 149 I=1,ICHAML(/1) 453 : MCHAML=ICHAML(I) 454 : SEGACT MCHAML 455 : DO 249 IC=1,IELVAL(/1) 456 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 457 : MELVAL=IELVAL(IC) 458 : SEGACT MELVAL 459 : DO 349 IEL=1,VELCHE(/2) 460 : COORFAC(I,IEL,3,3) = VELCHE(1,IEL) 461 : 349 CONTINUE 462 : SEGDES MELVAL 463 : ENDIF 464 : 249 CONTINUE 465 : SEGDES MCHAML 466 : 149 CONTINUE 467 : SEGDES MCHELM 468 : C 469 : SEGDES TAB1 470 : C 471 : C Initialisation du tableau des indicateurs d'interception 472 : C 473 : DO 302 I=1,NZ1 474 : DO 301 K=1,NBP 475 : INTER(I,K)=.FALSE. 476 : 301 CONTINUE 477 : 302 CONTINUE 478 : C 479 : C Boucle sur les facettes du maillage OMBRANT 480 : C 481 : MCHELM=CHX1 482 : SEGACT MCHELM 483 : DO 400 I=1,ICHAML(/1) 484 : MCHAML=ICHAML(I) 485 : SEGACT MCHAML 486 : DO 450 IC=1,IELVAL(/1) 487 : IF (TYPCHE(IC)(1:6) .EQ. 'REAL*8') THEN 488 : MELVAL=IELVAL(IC) 489 : SEGACT MELVAL 490 : DO 500 J=1,VELCHE(/2) 491 : XA1 = COORFAC(I,J,1,1) 492 : YA1 = COORFAC(I,J,1,2) 493 : ZA1 = COORFAC(I,J,1,3) 494 : C 495 : XB1 = COORFAC(I,J,2,1) 496 : YB1 = COORFAC(I,J,2,2) 497 : ZB1 = COORFAC(I,J,2,3) 498 : C 499 : XC1 = COORFAC(I,J,3,1) 500 : YC1 = COORFAC(I,J,3,2) 501 : ZC1 = COORFAC(I,J,3,3) 502 : C 503 : C Boucle sur les sous-zones du maillage OMBRE 504 : C 505 : DO 550 IZ=1,NZ1 506 : C 507 : C Boucle sur les lignes de champ (ou sur les elements POI1 de OMBRE) 508 : C 509 : DO 600 K=1,NBP 510 : IF (.NOT. INTER(IZ,K)) THEN 511 : C 512 : C Produits scalaires 513 : C 514 : PS1 = ((XPN(IZ,K)-XA1)*TXN(I,J)) + 515 : . ((YPN(IZ,K)-YA1)*TYN(I,J)) + 516 : . ((ZPN(IZ,K)-ZA1)*TZN(I,J)) 517 : PS2 = ((XPN1(IZ,K)-XA1)*TXN(I,J)) + 518 : . ((YPN1(IZ,K)-YA1)*TYN(I,J)) + 519 : . ((ZPN1(IZ,K)-ZA1)*TZN(I,J)) 520 : C -> --> 521 : C Calcul de PnPn+1 : 522 : C 523 : DEX = XPN1(IZ,K) - XPN(IZ,K) 524 : DEY = YPN1(IZ,K) - YPN(IZ,K) 525 : DEZ = ZPN1(IZ,K) - ZPN(IZ,K) 526 : C 527 : C calcul de la distance de connection par defaut 528 : C 529 : CHPAS0(IZ,K) = (DEX*DEX + DEY*DEY + DEZ*DEZ)**.5 530 : C 531 : C Test d'intersection avec le plan de la facette 532 : C 533 : IF ( (PS1*PS2 .LT. (-1*TOL1*TOL1)) 534 : . .OR. (PS2 .EQ. 0.) ) THEN 535 : C 536 : C -> --> -> 537 : C Calcul de AD1 = PnPn+1 . N : 538 : C 539 : AD1 = DEX*TXN(I,J) + DEY*TYN(I,J) + DEZ*TZN(I,J) 540 : C 541 : C Test de detection des lignes de champ paralleles a la facette 542 : C 543 : IF (ABS(AD1) .GT. TOL1) THEN 544 : C 545 : C 546 : C Calcul des points d'intersection M entre les lignes de champ et 547 : C le plan de la facette 548 : C 549 : XM = ( (XA1*DEX*TXN(I,J)) - 550 : . ((((YPN(IZ,K)-YA1)*DEX)- 551 : . (XPN(IZ,K)*DEY))*TYN(I,J)) - 552 : . ((((ZPN(IZ,K)-ZA1)*DEX)- 553 : . (XPN(IZ,K)*DEZ))*TZN(I,J)) ) / AD1 554 : C 555 : YM = ( (YA1*DEY*TYN(I,J)) - 556 : . ((((ZPN(IZ,K)-ZA1)*DEY)- 557 : . (YPN(IZ,K)*DEZ))*TZN(I,J)) - 558 : . ((((XPN(IZ,K)-XA1)*DEY)- 559 : . (YPN(IZ,K)*DEX))*TXN(I,J)) ) / AD1 560 : C 561 : ZM = ( (ZA1*DEZ*TZN(I,J)) - 562 : . ((((XPN(IZ,K)-XA1)*DEZ)- 563 : . (ZPN(IZ,K)*DEX))*TXN(I,J)) - 564 : . ((((YPN(IZ,K)-YA1)*DEZ)- 565 : . (ZPN(IZ,K)*DEY))*TYN(I,J)) ) / AD1 566 : C 567 : C Calcul des vecteurs AM, BM, CM 568 : C 569 : XAM = XM - XA1 570 : XBM = XM - XB1 571 : XCM = XM - XC1 572 : C 573 : C 574 : YAM = YM - YA1 575 : YBM = YM - YB1 576 : YCM = YM - YC1 577 : C 578 : ZAM = ZM - ZA1 579 : ZBM = ZM - ZB1 580 : ZCM = ZM - ZC1 581 : C 582 : C Denominateurs 583 : C 584 : DX = (YCM*ZBM)-(ZCM*YBM)+(ZAM*YBM)- 585 : . (ZAM*YCM)-(YAM*ZBM)+(YAM*ZCM) 586 : C 587 : DY = (ZCM*XBM)-(XCM*ZBM)+(XAM*ZBM)- 588 : . (XAM*ZCM)-(ZAM*XBM)+(ZAM*XCM) 589 : C 590 : DZ = (YCM*XBM)-(XCM*YBM)+(XAM*YBM)- 591 : . (XAM*YCM)-(YAM*XBM)+(YAM*XCM) 592 : C 593 : IF (ABS(DZ) .GT. TOL1) THEN 594 : D1 = DZ 595 : A1 = YCM*XBM-XCM*YBM 596 : B1 = YAM*XCM-XAM*YCM 597 : C1 = YBM*XAM-XBM*YAM 598 : ELSEIF (ABS(DY) .GT. TOL1) THEN 599 : D1 = DY 600 : A1 = ZCM*XBM-XCM*ZBM 601 : B1 = ZAM*XCM-XAM*ZCM 602 : C1 = ZBM*XAM-XBM*ZAM 603 : ELSE 604 : D1 = DX 605 : A1 = YCM*ZBM-ZCM*YBM 606 : B1 = YAM*ZCM-ZAM*YCM 607 : C1 = YBM*ZAM-ZBM*YAM 608 : ENDIF 609 : C 610 : C Coordonnees barycentriques 611 : C 612 : ALPHA = A1 / D1 613 : BETA = B1 / D1 614 : GAMMA = C1 / D1 615 : C 616 : IF ( (ALPHA .GE. 0.) .AND. 617 : . (BETA .GE. 0.) .AND. 618 : . (GAMMA .GE. 0.) ) THEN 619 : C 620 : INTER(IZ,K)=.TRUE. 621 : C 622 : C Calcul de d(Pn,M) : 623 : C 624 : CHPAS(IZ,K) = ((XPN(IZ,K)-XM)**2. + 625 : . (YPN(IZ,K)-YM)**2. + (ZPN(IZ,K)-ZM)**2.)**.5 626 : ENDIF 627 : ENDIF 628 : ENDIF 629 : ENDIF 630 : 600 CONTINUE 631 : 550 CONTINUE 632 : 500 CONTINUE 633 : SEGDES MELVAL 634 : ENDIF 635 : 450 CONTINUE 636 : SEGDES MCHAML 637 : 400 CONTINUE 638 : SEGDES MCHELM 639 : C 640 : C-------------------------------------------------------- 641 : C 642 : C Creation du maillage MINTER des points d'intersection 643 : C 644 : NBNN = 1 645 : NBELEM = NBP 646 : NBSOUS = 0 647 : NBREF = 0 648 : SEGINI MELEME 649 : MINTER = MELEME 650 : ITYPEL = 1 651 : C 652 : C Construction de MINTER 653 : C 654 : IPT1 = ICHOLD 655 : SEGACT IPT1 656 : NINTER = 0 657 : DO 701 I=1,NZ1 658 : DO 700 K=1,NBP 659 : IF (INTER(I,K)) THEN 660 : NINTER = NINTER+1 661 : NUM(1,NINTER) = IPT1.NUM(1,K) 662 : ENDIF 663 : 700 CONTINUE 664 : 701 CONTINUE 665 : NBELEM = NINTER 666 : SEGADJ MELEME 667 : SEGDES MELEME,IPT1 668 : C-------------------------------------------------------- 669 : C 670 : C Creation du CHPOINT CHDIST 671 : C 672 : C segment MCHPOI 673 : NAT = 1 674 : NSOUPO = NZ1 675 : SEGINI MCHPOI 676 : ICHDIS = MCHPOI 677 : IFOPOI = 2 678 : JATTRI(1) = 2 679 : C segment MSOUPO 680 : NC = 1 681 : DO 901 I=1,NZ1 682 : SEGINI MSOUPO 683 : IPCHP(I)=MSOUPO 684 : NOCOMP(1)= 'SCAL' 685 : C segment MELEME : maillage associe a CHDIST 686 : NBNN = 1 687 : NBELEM = NBP 688 : NBSOUS = 0 689 : NBREF = 0 690 : C 691 : C LE CHAMPOINT CHDIST S'APPUIE SUR LE MEME MAILLAGE QUE CHOLD 692 : C 693 : IGEOC=ICHOLD 694 : C 695 : C Construction de MPOVAL 696 : C 697 : N = NBP 698 : SEGINI MPOVAL 699 : IPOVAL=MPOVAL 700 : C 701 : C On met la valeur de la distance de connection dans le chpoint CHDIST 702 : C Ce point n'existera plus dans le prochain maillage MINTER 703 : C 704 : DO 900 K=1,NBP 705 : IF (INTER(I,K)) THEN 706 : VPOCHA(K,1)=CHPAS(I,K) 707 : ELSE 708 : VPOCHA(K,1)=CHPAS0(I,K) 709 : ENDIF 710 : 900 CONTINUE 711 : C 712 : SEGDES MPOVAL 713 : SEGDES MSOUPO 714 : 901 CONTINUE 715 : SEGDES MCHPOI 716 : C 717 : C-------------------------------------------------------- 718 : C 719 : C Ecriture des nouveaux objets en sortie 720 : C 720 : CALL ECROBJ('MAILLAGE',MINTER) 721 : C 721 : CALL ECROBJ('CHPOINT ',ICHDIS) 722 : C 723 : SEGSUP MTRAV1 724 : SEGSUP MTRAV2 725 : C 726 : RETURN 727 : END 728 : 729 : 730 : 731 : 732 : 733 : 734 :
© Cast3M 2003 - All rights reserved.
Disclaimer