1 : C J3COAL SOURCE CHAT 05/01/13 00:46:02 5004 2 : SUBROUTINE J3COAL(WORK1,WORK2,LCAONB,VWORK,NFA,TOL,IRET) 3 : C---------------------------------------------------- 4 : C COALESCENCE DES TROUS A ET B 5 : C 6 : C CODE IST(1,I): 0 point non traite 7 : C 1 est sur le segment IST(2,I) 8 : C 2 est sur les segments IST(2,I) et IST(3,I) 9 : C -1 est a l'interieur 10 : C -2 est a l'exterieur 11 : C 12 : C CODE CRO(J,I): 1 cote sur le segment 13 : C -1 cote interieur 14 : C -2 cote exterieur 15 : C 16 : C PP 6/97 17 : C Pierre Pegon/JRC Ispra 18 : C---------------------------------------------------- 19 : IMPLICIT INTEGER(I-N) 20 : IMPLICIT REAL*8(A-H,O-Z) 21 : -INC CCOPTIO 22 : C 23 : SEGMENT WORK 24 : REAL*8 XYC(2,NPTO) 25 : INTEGER IST(3,NPTO) 26 : REAL*8 DENS(NPTO) 27 : INTEGER JUN 28 : ENDSEGMENT 29 : POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK 30 : C 31 : SEGMENT WWORK 32 : REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3) 33 : INTEGER FWORK 34 : INTEGER TWORK(NTROU) 35 : ENDSEGMENT 36 : C 37 : SEGMENT VWORK 38 : INTEGER FWWORK(NFACE) 39 : ENDSEGMENT 40 : C 41 : SEGMENT JUNC 42 : INTEGER CRO(2,NPTO) 43 : ENDSEGMENT 44 : C 45 : LOGICAL LCONTI,LAINB,LAOUB,LCAONB 46 : DIMENSION XY(2) 47 : C 48 : IF (IIMPI.EQ.1789)THEN 49 : WRITE(IOIMP,*)'>>> On entre dans j3coal <<<' 50 : ENDIF 51 : C 52 : VWORK=0 53 : NFA=0 54 : C 55 : C ON S'OCCUPE DU CAS DU CONTACT MULTI-PONCTUEL MAIS SANS COTE 56 : C COMMUN ENTRE A ET B. POUR CELA, ON "MERGE" A ET B AU NIVEAU 57 : C D'UN POINT COMMUN ET ON PASSE LE RESULTAT A LA MOULINETTE "14" 58 : C DES POINTS COMMUNS 59 : C 60 : IF(.NOT.LCAONB)THEN 61 : NPTO1=WORK1.XYC(/2) 62 : NPTO2=WORK2.XYC(/2) 63 : C 64 : IPTO=0 65 : NPTO=NPTO1+NPTO2 66 : SEGINI,WORK 67 : C 68 : DO IE1=1,NPTO1 69 : IPTO=IPTO+1 70 : DO IE2=1,2 71 : XYC(IE2,IPTO)=WORK1.XYC(IE2,IE1) 72 : ENDDO 73 : DENS(IPTO)=WORK1.DENS(IE1) 74 : IF(WORK1.IST(1,IE1).EQ.2)GOTO 100 75 : ENDDO 76 : C 77 : IRET=IRET+1 78 : WRITE(IOIMP,*)'J3COAL: ON NE TROUVE PAS DE POINT COMMUN' 79 : RETURN 80 : 100 CONTINUE 81 : I1=IE1 82 : C 82 : CALL J3NUMP(WORK1.IST(1,I1),NPTO2,I2) 83 : C 84 : DO IE1=1,NPTO2 85 : I2=I2+1 86 : IF(I2.GT.NPTO2)I2=I2-NPTO2 87 : IPTO=IPTO+1 88 : DO IE2=1,2 89 : XYC(IE2,IPTO)=WORK2.XYC(IE2,I2) 90 : ENDDO 91 : DENS(IPTO)=WORK2.DENS(I2) 92 : ENDDO 93 : C 94 : IF(I1.NE.NPTO1)THEN 95 : DO IE1=I1+1,NPTO1 96 : IPTO=IPTO+1 97 : DO IE2=1,2 98 : XYC(IE2,IPTO)=WORK1.XYC(IE2,IE1) 99 : ENDDO 100 : DENS(IPTO)=WORK1.DENS(IE1) 101 : ENDDO 102 : ENDIF 103 : C 104 : JUNC=WORK1.JUN 105 : IF(JUNC.NE.0)SEGSUP,JUNC 106 : SEGSUP,WORK1 107 : WORK1=WORK 108 : C 109 : GOTO 14 110 : C 111 : ENDIF 112 : C 113 : C ON COMPTE LE NOMBRE DE PLAGES OU A ET B ONT DES COTES COMMUNS 114 : C (ON FAIT UN RECOUVREMENT POUR ETRE SUR DU BON COMPTE: L'ALGO 115 : C SE PLANTE SI TOUS LES COTES SONT CONTIGUS, CE QUI EST IMPOSSIBLE) 116 : C 117 : I1=0 118 : LCONTI=.FALSE. 119 : NPTO1=WORK1.XYC(/2) 120 : JUNC=WORK1.JUN 121 : DO IE1=1,NPTO1 122 : ICRO=CRO(1,IE1) 123 : IF(ICRO.EQ.1)THEN 124 : IF(.NOT.LCONTI)THEN 125 : LCONTI=.TRUE. 126 : I1=I1+1 127 : ENDIF 128 : ELSE 129 : LCONTI=.FALSE. 130 : ENDIF 131 : ENDDO 132 : ICRO=CRO(2,NPTO1) 133 : IF(ICRO.EQ.1.AND.LCONTI)I1=I1-1 134 : C 135 : IF(I1.EQ.0)THEN 136 : IRET=IRET+1 137 : WRITE(IOIMP,*)'J3COAL: ON SE PLANTE SUR I1=0!' 138 : RETURN 139 : ENDIF 140 : NPTO2=WORK2.XYC(/2) 141 : IF(I1.EQ.1)GOTO 10 142 : C 143 : C ON PREPARE LA STRUCTURE DE DONNEE QUI RECEUILLERA LES NOUVELLES FACES 144 : C 145 : NFACE=I1-1 146 : SEGINI,VWORK 147 : C 148 : C S'IL Y A PLUSIEURS PLAGES, ON CHERCHE A LES REDUIRE A UNE 149 : C EN SUPPRIMANT LES TROUS 150 : C 151 : C A) On cree WORK3 qui contiendra a la fin le nouveau contour de A 152 : C 153 : NPTO=NPTO1+NPTO2 154 : IPTO3=0 155 : SEGINI,WORK3 156 : WORK3.JUN=0 157 : C 158 : C B) On boucle sur I1=nbtrou+1 159 : C 160 : IPLA1=1 161 : NTRO1=I1-1 162 : I0=I1 163 : DO IE0=1,I0 164 : C 165 : C C) On cherche la fin d'une plage 166 : C tout en recopiant les bords dans WORK3 167 : C 168 : DO IE1=IPLA1,NPTO1 169 : ICRO=CRO(1,IE1) 170 : ICRP=CRO(2,IE1) 171 : IF((ICRO-1)*(ICRP-1).EQ.0)THEN 172 : IPTO3=IPTO3+1 173 : DO IE2=1,2 174 : WORK3.XYC(IE2,IPTO3)=WORK1.XYC(IE2,IE1) 175 : ENDDO 176 : WORK3.DENS(IPTO3)=WORK1.DENS(IE1) 177 : ENDIF 178 : IF(ICRO.EQ.1.AND.ICRP.EQ.-2) GOTO 1 179 : ENDDO 180 : IRET=IRET+1 181 : WRITE(IOIMP,*)'J3COAL: ON NE TROUVE PAS UNE FIN DE PLAGE' 182 : RETURN 183 : 1 CONTINUE 184 : IPLA1=IE1 185 : C 186 : C D) On forme le candidat trou: on commence par le morceau sur A 187 : C 188 : NPTO=NPTO1+NPTO2 189 : IPTO=0 190 : SEGINI,WORK 191 : JUN=0 192 : DO IE1=1,NPTO1 193 : C 194 : I1=IE1+IPLA1-1 195 : IF(I1.GT.NPTO1)I1=I1-NPTO1 196 : C 197 : IPTO=IPTO+1 198 : DO IE2=1,2 199 : XYC(IE2,IPTO)=WORK1.XYC(IE2,I1) 200 : ENDDO 201 : DENS(IPTO)=WORK1.DENS(I1) 202 : C 203 : ICRO=CRO(1,I1) 204 : ICRP=CRO(2,I1) 205 : IF(ICRO.EQ.-2.AND.ICRP.EQ.1)GOTO 2 206 : C 207 : ENDDO 208 : IRET=IRET+1 209 : WRITE(IOIMP,*)'J3COAL: ON NE TROUVE PAS LA FIN D"UN TROU' 210 : RETURN 211 : 2 CONTINUE 212 : IPLB1=I1 213 : C 214 : C E) On continue par le morceau sur B jusqu'a refermeture 215 : C 216 : IF(WORK1.IST(1,IPLB1).NE.2)THEN 217 : IRET=IRET+1 218 : WRITE(IOIMP,*)'J3COAL: LA FIN DU TROU DE A DOIT SE TROUVER' 219 : WRITE(IOIMP,*)' SUR 2 COTES DE B' 220 : RETURN 221 : ENDIF 222 : C 223 : XX=XYC(1,1) 224 : YY=XYC(2,1) 225 : C 225 : CALL J3NUMP(WORK1.IST(1,I1),NPTO2,IPLA2) 226 : C 227 : DO IE1=1,NPTO2 228 : I1=IE1+IPLA2 229 : IF(I1.GT.NPTO2)I1=I1-NPTO2 230 : C 231 : DO IE2=1,2 232 : XY(IE2)=WORK2.XYC(IE2,I1) 233 : ENDDO 234 : C 235 : DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2) 236 : IF(DIS.LT.TOL)GOTO 3 237 : C 238 : IPTO=IPTO+1 239 : DO IE2=1,2 240 : XYC(IE2,IPTO)=XY(IE2) 241 : ENDDO 242 : DENS(IPTO)=WORK2.DENS(I1) 243 : C 244 : ENDDO 245 : IRET=IRET+1 246 : WRITE(IOIMP,*)'J3COAL: LE CANDIDAT TROU NE SE REFERME PAS' 247 : RETURN 248 : 3 CONTINUE 249 : NPTO=IPTO 250 : SEGADJ,WORK 251 : IPLB2=I1 252 : C 253 : C F) On verifie que le trou ne contient strictement aucun pt de A 254 : C et qu'il contient au moins un point exterieur 255 : C 256 : LAINB=.FALSE. 257 : LAOUB=.FALSE. 258 : DO IE1=1,NPTO1 259 : DO IE2=1,2 260 : XY(IE2)=WORK1.XYC(IE2,IE1) 261 : ENDDO 261 : CALL J3INEX(XY,XYC,NPTO,TOL,ICOD,ISIGM,IRET) 262 : IF(IRET.NE.0)RETURN 263 : IF(ICOD.EQ.-1)LAINB=.TRUE. 264 : IF(ICOD.EQ.-2)LAOUB=.TRUE. 265 : ENDDO 266 : C 267 : C G) Si le trou contient un point de A, ce n'est pas un trou... 268 : C et on recopie la suite de A 269 : C 270 : IF(LAINB)THEN 271 : IF(LAOUB)THEN 272 : IRET=IRET+1 273 : WRITE(IOIMP,*)'J3COAL: CE TROU ERRONE NE PEUT ETRE' 274 : WRITE(IOIMP,*) ' HORS DE A' 275 : RETURN 276 : ENDIF 277 : NPL1=IPLB1-IPLA1-1 278 : IF(NPL1.LT.0)NPL1=NPL1+NPTO1 279 : IF (NPL1.NE.0)THEN 280 : DO IE1=1,NPL1 281 : I1=IPLA1+IE1 282 : IF(I1.GT.NPTO1)I1=I1-NPTO1 283 : IPTO3=IPTO3+1 284 : DO IE2=1,2 285 : WORK3.XYC(IE2,IPTO3)=WORK1.XYC(IE2,I1) 286 : ENDDO 287 : WORK3.DENS(IPTO3)=WORK1.DENS(I1) 288 : ENDDO 289 : ENDIF 290 : C 291 : C G) Sinon on valide le trou ... 292 : C (son orientation type face devrait-etre OK) 293 : C 294 : ELSE 295 : IF(.NOT.LAOUB)THEN 296 : IRET=IRET+1 297 : WRITE(IOIMP,*)'J3COAL: LE NOUVEAU TROU NE PEUT CONTENIR A' 298 : RETURN 299 : ENDIF 300 : C 301 : NTRO1=NTRO1-1 302 : NTROU=0 303 : SEGINI,WWORK 304 : FWORK=WORK 305 : FWWORK(NFACE-NTRO1)=WWORK 306 : NFA=NFA+1 307 : C 308 : C H) ... et on change le contours de A (WORK3) (SEULEMENT 309 : C avec des points INTERIEURS a B parcouru a l'envers) 310 : C 311 : NPL2=IPLB2-IPLA2-1 312 : IF(NPL2.LT.0)NPL2=NPL2+NPTO2 313 : IF (NPL2.NE.0)THEN 314 : DO IE1=1,NPL2 315 : I1=IPLB2-IE1 316 : IF(I1.GT.NPTO2)I1=I1-NPTO2 317 : IPTO3=IPTO3+1 318 : DO IE2=1,2 319 : WORK3.XYC(IE2,IPTO3)=WORK2.XYC(IE2,I1) 320 : ENDDO 321 : WORK3.DENS(IPTO3)=WORK2.DENS(I1) 322 : ENDDO 323 : ENDIF 324 : ENDIF 325 : C 326 : C ?) Fin de boucle sur les trou 327 : C 328 : IPLA1=IPLB1 329 : IF(NTRO1.EQ.0)GOTO 4 330 : ENDDO 331 : IRET=IRET+1 332 : WRITE(IOIMP,*)'J3COAL: LE NOMBRE DE TROU EST INCONSISTENT' 333 : RETURN 334 : C 335 : C I) On termine A (WORK3) jusqu'a fermeture 336 : C 337 : 4 CONTINUE 338 : C 339 : XX=WORK3.XYC(1,1) 340 : YY=WORK3.XYC(2,1) 341 : DO IE1=1,NPTO1 342 : I1=IE1+IPLA1-1 343 : IF(I1.GT.NPTO1)I1=I1-NPTO1 344 : C 345 : DO IE2=1,2 346 : XY(IE2)=WORK1.XYC(IE2,I1) 347 : ENDDO 348 : C 349 : DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2) 350 : IF(DIS.LT.TOL)GOTO 5 351 : C 352 : IPTO3=IPTO3+1 353 : DO IE2=1,2 354 : WORK3.XYC(IE2,IPTO3)=XY(IE2) 355 : ENDDO 356 : WORK3.DENS(IPTO3)=WORK1.DENS(I1) 357 : C 358 : ENDDO 359 : C 360 : IRET=IRET+1 361 : WRITE(IOIMP,*)'J3COAL: ON N"ARRIVE PAS A REFERMER A' 362 : RETURN 363 : C 364 : C J) On ajuste A (WORK3) et on le re-compare a B 365 : C 366 : 5 CONTINUE 367 : NPTO=IPTO3 368 : SEGADJ,WORK3 369 : C 369 : CALL J3COTO(WORK3,WORK2,TOL,IRET) 370 : IF(IRET.NE.0)RETURN 370 : CALL J3JUNC(WORK3,WORK2,TOL,IRET) 371 : IF(IRET.NE.0)RETURN 371 : CALL J3JUNC(WORK2,WORK3,TOL,IRET) 372 : IF(IRET.NE.0)RETURN 373 : C 374 : C K) Si OK on substitue WORK3 a WORK1 375 : C 376 : JUNC=WORK1.JUN 377 : IF(JUNC.NE.0)SEGSUP,JUNC 378 : SEGSUP,WORK1 379 : WORK1=WORK3 380 : NPTO1=WORK1.XYC(/2) 381 : C ??? 382 : NPTO2=WORK2.XYC(/2) 383 : C ??? 384 : C 385 : C QUAND IL N'Y A PLUS QU'UNE SEULE PLAGE, ON COALESCE NORMALEMENT 386 : C 387 : 10 CONTINUE 388 : C 389 : NPTO=NPTO1+NPTO2 390 : IPTO3=0 391 : SEGINI,WORK3 392 : WORK3.JUN=0 393 : C 394 : C A) On recopie dans WORK3 les points de A exterieurs a B jusqu'au 395 : C debut de la plage de contact 396 : C 397 : JUNC=WORK1.JUN 398 : DO IE1=1,NPTO1 399 : ICRO=CRO(1,IE1) 400 : ICRP=CRO(2,IE1) 401 : IF(ICRO*ICRP.EQ.4)THEN 402 : IPTO3=IPTO3+1 403 : DO IE2=1,2 404 : WORK3.XYC(IE2,IPTO3)=WORK1.XYC(IE2,IE1) 405 : ENDDO 406 : WORK3.DENS(IPTO3)=WORK1.DENS(IE1) 407 : ENDIF 408 : IF(ICRO.EQ.-2.AND.ICRP.EQ.1)GOTO 11 409 : ENDDO 410 : IRET=IRET+1 411 : WRITE(IOIMP,*)'J3COAL: ON NE TROUVE PAS UN DEBUT DE PLAGE' 412 : RETURN 413 : C 414 : C B) On recopie les points de B jusqu'au debut de la plage (vue de B) 415 : C 416 : 11 CONTINUE 417 : IF(WORK1.IST(1,IE1).NE.2)THEN 418 : IRET=IRET+1 419 : WRITE(IOIMP,*)'J3COAL: QUAND ON PASSE SUR B LE POINT DOIT ETRE' 420 : WRITE(IOIMP,*)' SUR 2 COTES DE B' 421 : RETURN 422 : ENDIF 423 : C 423 : CALL J3NUMP(WORK1.IST(1,IE1),NPTO2,IPLA2) 424 : C 425 : JUNC=WORK2.JUN 426 : DO IE1=1,NPTO2 427 : I1=IE1+IPLA2-1 428 : IF(I1.GT.NPTO2)I1=I1-NPTO2 429 : C 430 : IPTO3=IPTO3+1 431 : DO IE2=1,2 432 : WORK3.XYC(IE2,IPTO3)=WORK2.XYC(IE2,I1) 433 : ENDDO 434 : WORK3.DENS(IPTO3)=WORK2.DENS(I1) 435 : C 436 : ICRO=CRO(1,I1) 437 : ICRP=CRO(2,I1) 438 : IF(ICRO.EQ.-2.AND.ICRP.EQ.1)GOTO 12 439 : C 440 : ENDDO 441 : IRET=IRET+1 442 : WRITE(IOIMP,*)'J3COAL: LA PARTIE B DE LA COALESCENCE NE RETOMBE' 443 : WRITE(IOIMP,*)' PAS SUR UNE PLAGE' 444 : RETURN 445 : C 446 : C C) On finit la boucle sur A 447 : C 448 : 12 CONTINUE 449 : IE1=I1 450 : IF(WORK2.IST(1,IE1).NE.2)THEN 451 : IRET=IRET+1 452 : WRITE(IOIMP,*)'J3COAL: QUAND ON PASSE SUR A LE POINT DOIT ETRE' 453 : WRITE(IOIMP,*)' SUR 2 COTES DE A' 454 : RETURN 455 : ENDIF 456 : C 456 : CALL J3NUMP(WORK2.IST(1,IE1),NPTO1,IPLA1) 457 : XX=WORK3.XYC(1,1) 458 : YY=WORK3.XYC(2,1) 459 : C 460 : DO IE1=1,NPTO1 461 : I1=IE1+IPLA1 462 : IF(I1.GT.NPTO1)I1=I1-NPTO1 463 : C 464 : DO IE2=1,2 465 : XY(IE2)=WORK1.XYC(IE2,I1) 466 : ENDDO 467 : C 468 : DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2) 469 : IF(DIS.LT.TOL)GOTO 13 470 : C 471 : IPTO3=IPTO3+1 472 : DO IE2=1,2 473 : WORK3.XYC(IE2,IPTO3)=XY(IE2) 474 : ENDDO 475 : WORK3.DENS(IPTO3)=WORK1.DENS(I1) 476 : C 477 : ENDDO 478 : C 479 : IRET=IRET+1 480 : WRITE(IOIMP,*)'J3COAL: ON N"ARRIVE PAS A REFERMER A' 481 : RETURN 482 : C 483 : C ON DIMENSIONNE CORRECTEMENT WORK3 QUE L'ON SUBSTITUE ENSUITE 484 : C A WORK1 485 : C 486 : 13 CONTINUE 487 : C 488 : NPTO=IPTO3 489 : SEGADJ,WORK3 490 : C 491 : JUNC=WORK1.JUN 492 : IF(JUNC.NE.0)SEGSUP,JUNC 493 : SEGSUP,WORK1 494 : WORK1=WORK3 495 : C 496 : C ENFIN ON VERIFIE QU'IL N'Y A PAS DES POINTS COMMUNS 497 : C 498 : 14 CONTINUE 499 : NPTO1=WORK1.XYC(/2) 500 : DO IE1=1,NPTO1 501 : WORK1.IST(1,IE1)=0 502 : ENDDO 503 : DO 21 IE1=1,NPTO1 504 : XX=WORK1.XYC(1,IE1) 505 : YY=WORK1.XYC(2,IE1) 506 : DO 20 IE2=1,NPTO1 507 : IF(IE2.EQ.IE1)GOTO 20 508 : DO IE3=1,2 509 : XY(IE3)=WORK1.XYC(IE3,IE2) 510 : ENDDO 511 : DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2) 512 : IF(DIS.LT.TOL)THEN 513 : WORK1.IST(1,IE1)=IE2 514 : GOTO 21 515 : ENDIF 516 : 20 CONTINUE 517 : 21 CONTINUE 518 : C 519 : I1=0 520 : DO IE1=1,NPTO1 521 : IF(WORK1.IST(1,IE1).NE.0)I1=I1+1 522 : ENDDO 523 : C 524 : C I1 DOIT ETRE UN MULTIPLE DE 2 525 : C 526 : IF(I1-(I1/2)*2.NE.0)THEN 527 : IRET=IRET+1 528 : WRITE(IOIMP,*) 529 : > 'J3COAL: LE NB DE PTS COMMUNS DOIT ETRE UN MULTIPLE DE 2' 530 : RETURN 531 : ENDIF 532 : I1=I1/2 533 : C 534 : C S'IL N'Y EN A PAS, ON PEUT SORTIR ... 535 : C 536 : IF(I1.EQ.0)RETURN 537 : C 538 : C SINON C'EST REPARTI POUR UN TOUR! 539 : C 540 : C A) On prepare la structure de donnes qui contiendra 541 : C les nouvelles faces 542 : C 543 : IF(LCAONB)THEN 544 : NTRO1=I1 545 : ELSE 546 : NTRO1=I1-1 547 : ENDIF 548 : IF(VWORK.EQ.0)THEN 549 : NFACE=NTRO1 550 : SEGINI,VWORK 551 : ELSE 552 : NFACE=FWWORK(/1) 553 : NFACE=NFACE+NTRO1 554 : SEGADJ,VWORK 555 : ENDIF 556 : WORK3=0 557 : C 558 : C B) On cherche les plages contigues entre les intersections 559 : C (il y en a NFACE+1) mais seules NFACE sont des trous 560 : C On attaque la boucle 561 : C 562 : IPLA1=1 563 : I0=NTRO1+1 564 : DO IE0=1,I0 565 : C 566 : C C) On localise le premier pont 567 : C 568 : DO IE1=IPLA1,NPTO1 569 : I1=WORK1.IST(1,IE1) 570 : IF(I1.NE.0)GOTO 30 571 : ENDDO 572 : IRET=IRET+1 573 : WRITE(IOIMP,*) 574 : > 'J3COAL: ON NE TROUVE PAS LE NB CORRECT DE CONTOURS' 575 : RETURN 576 : C 577 : C D) On prepare le nouveau contours 578 : C 579 : 30 CONTINUE 580 : NPTO=NPTO1 581 : IPTO=0 582 : SEGINI,WORK 583 : JUN=0 584 : C 585 : C E) On referme le contour sur le point de premier pont en 586 : C sautant eventuellement de pont en pont et en les coupant 587 : C au fur et a mesure 588 : C 589 : IPLA1=IE1 590 : WORK1.IST(1,IE1)=0 591 : C 592 : DO IE1=1,NPTO1 593 : C 594 : IPTO=IPTO+1 595 : DO IE2=1,2 596 : XYC(IE2,IPTO)=WORK1.XYC(IE2,I1) 597 : ENDDO 598 : DENS(IPTO)=WORK1.DENS(I1) 599 : C 600 : I1=I1+1 601 : IF(I1.GT.NPTO1)I1=I1-NPTO1 602 : IF(I1.EQ.IPLA1)GOTO 31 603 : C 604 : I2=WORK1.IST(1,I1) 605 : IF(I2.NE.0)THEN 606 : WORK1.IST(1,I1)=0 607 : I1=I2 608 : ENDIF 609 : IF(I1.EQ.IPLA1)GOTO 31 610 : ENDDO 611 : IRET=IRET+1 612 : WRITE(IOIMP,*) 613 : > 'J3COAL: ON NE TROUVE PAS LE NB CORRECT DE CONTOURS' 614 : RETURN 615 : C 616 : C F) On ajuste le contours 617 : C 618 : 31 CONTINUE 619 : NPTO=IPTO 620 : SEGADJ,WORK 621 : C 622 : C G) On verifie que le trou ne contient strictement aucun pt de A 623 : C et qu'il contient au moins un point exterieur 624 : C 625 : LAINB=.FALSE. 626 : LAOUB=.FALSE. 627 : NPTO=IPTO 628 : SEGADJ,WORK 629 : DO IE1=1,NPTO1 630 : DO IE2=1,2 631 : XY(IE2)=WORK1.XYC(IE2,IE1) 632 : ENDDO 632 : CALL J3INEX(XY,XYC,NPTO,TOL,ICOD,ISIGM,IRET) 633 : IF(IRET.NE.0)RETURN 634 : IF(ICOD.EQ.-1)LAINB=.TRUE. 635 : IF(ICOD.EQ.-2)LAOUB=.TRUE. 636 : ENDDO 637 : C 638 : C H) Si le trou contient un point de A, ce n'est pas un trou... 639 : C C'est en fait la silhouette de A (bien oriente!) 640 : C 641 : IF(LAINB)THEN 642 : IF(LAOUB)THEN 643 : IRET=IRET+1 644 : WRITE(IOIMP,*)'J3COAL: LA NOUVELLE SILHOUETTE NE PEUT ETRE' 645 : WRITE(IOIMP,*) ' HORS DE A' 646 : RETURN 647 : ENDIF 648 : WORK3=WORK 649 : C 650 : C I) Sinon on valide le trou ... 651 : C (son orientation type face devrait-etre OK) 652 : C 653 : ELSE 654 : IF(.NOT.LAOUB)THEN 655 : IRET=IRET+1 656 : WRITE(IOIMP,*)'J3COAL: LE NOUVEAU TROU NE PEUT CONTENIR A' 657 : RETURN 658 : ENDIF 659 : C 660 : NTRO1=NTRO1-1 661 : NTROU=0 662 : SEGINI,WWORK 663 : FWORK=WORK 664 : FWWORK(NFACE-NTRO1)=WWORK 665 : NFA=NFA+1 666 : C 667 : ENDIF 668 : C 669 : C J) On finit la boucle 670 : C 671 : ENDDO 672 : C 673 : C K) A ce point NTRO1 doit etre nul et WORK3 NE 0 674 : C 675 : IF((NTRO1.NE.0).OR.(WORK3.EQ.0))THEN 676 : IRET=IRET+1 677 : WRITE(IOIMP,*)'J3COAL: LE NOMBRE DE CONTOURS EST INCONSISTENT' 678 : RETURN 679 : ENDIF 680 : C 681 : C L) WORK3 "nouveau A" vient substituer A 682 : C 683 : JUNC=WORK1.JUN 684 : IF(JUNC.NE.0)SEGSUP,JUNC 685 : SEGSUP,WORK1 686 : WORK1=WORK3 687 : C 688 : RETURN 689 : END 690 : 691 :
© Cast3M 2003 - All rights reserved.
Disclaimer