1 : C J3SURE SOURCE CHAT 05/01/13 00:47:25 5004 2 : SUBROUTINE J3SURE(VWORK1,IRET,TOL) 3 : C---------------------------------------------------- 4 : C ELIMINATION DES CAS TORDUS POUR SURF 5 : C QUI CREE DE NOUVELLE FACES: 6 : C 7 : C - CYCLE INTERIEUR DE TROU 8 : C - CYCLE DE TROU AVEC LE CONTOUR PRINCIPAL 9 : C 10 : C PP 12/98 11 : C Pierre Pegon/JRC Ispra 12 : C---------------------------------------------------- 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8(A-H,O-Z) 15 : DIMENSION XY(2) 16 : C 17 : -INC CCOPTIO 18 : C 19 : SEGMENT VWORK 20 : INTEGER FWWORK(NFACE) 21 : ENDSEGMENT 22 : POINTEUR VWORK1.VWORK,VWORK2.VWORK,VWDUMM.VWORK 23 : C 24 : SEGMENT WWORK 25 : REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3) 26 : INTEGER FWORK 27 : INTEGER TWORK(NTROU) 28 : ENDSEGMENT 29 : POINTEUR WWORK1.WWORK 30 : C 31 : SEGMENT WORK 32 : REAL*8 XYC(2,NPTO) 33 : INTEGER IST(3,NPTO) 34 : REAL*8 DENS(NPTO) 35 : INTEGER JUN 36 : ENDSEGMENT 37 : POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK 38 : C 39 : SEGMENT JUNC 40 : INTEGER CRO(2,NPTO) 41 : ENDSEGMENT 42 : C 43 : SEGMENT WCYCL 44 : C CONNEC(.,.,J)=NO DU CONTOUR CONCERNE 45 : C CONNEC(.,I,J)=IEME VOISIN DU TROU J 46 : C CONNEC(1,.,.)=NO DU POINT 47 : C CONNEC(2,.,.)=NO DU CONTOUR EN CONTACT 48 : C CONNEC(1,.,.)=NO DU POINT 49 : INTEGER CONNEC(3,NTROV,NTROV) 50 : C NCONNE(J)=NB DE VOISIN DU TROU J 51 : INTEGER NCONNE(NTROV) 52 : C NCYCLE(.,I)=NIVEAU DANS LE CYCLE DE TROU 53 : C NCYCLE(1,,)=TROU AMONT 54 : C NCYCLE(2,,)=TROU COURANT 55 : C NCYCLE(3,,)=RANG DU VOISIN COURANT 56 : INTEGER NCYCLE(3,NTROV) 57 : INTEGER NINDEX(NTROV) 58 : ENDSEGMENT 59 : C 60 : C ON RENTRE AVEC DES ENSEMBLE DE VWORK REPRESENTANT CHACUN 61 : C UN BLOCK COMPOSE DE FACE 62 : C 63 : NBLOCK=VWORK1.FWWORK(/1) 64 : C 65 : C ON BOUCLE SUR CHAQUE BLOCK 66 : C 67 : DO IE1=1,NBLOCK 68 : VWORK=VWORK1.FWWORK(IE1) 69 : NFACF=FWWORK(/1) 70 : C 71 : C ON BOUCLE SUR CHAQUE FACE (ON SIMULE DO 1000 IE2=1,NFACE 72 : C 73 : C DO 1000 IE2=1,NFACE 74 : C 75 : IE2=0 76 : 1000 IE2=IE2+1 77 : IF (IE2.GT.NFACF)GOTO 1001 78 : C 79 : WWORK=FWWORK(IE2) 80 : NTROU=TWORK(/1) 81 : C 82 : C S'IL Y A MOINS DE 2 TROUS, IL N'Y A PAS POSSIBILITE DE CYCLE INTE 83 : C OU EXTE ET ALORS ON NE FAIT RIEN 84 : C EN FAIT J3SURE LUI MEME PEUT CREER DES FACES AVEC UN TROU... QUI 85 : C SONT CANDIDAT A LA COUPE... 86 : C 87 : C IF(NTROU.LT.2)GOTO 1000 88 : IF(NTROU.EQ.0)GOTO 1000 89 : C 90 : C ON CHERCHE QUI EST EN CONTACT (PONCTUEL) AVEC QUOI 91 : C ON CHERCHE MEME AU DELA DE 1 PT [CAR LA COALESCENCE DE TROUS EN 92 : C CONTACT AVEC UN SEUL POINT PEUT CREER DU CONTACT MULTI POINT!) 93 : C 94 : NTROV=NTROU+1 95 : SEGINI,WCYCL 96 : DO JE1=1,NTROU 97 : NCONNE(JE1)=0 98 : ENDDO 99 : C 100 : C WARNING: S'IL N'Y A QU'UN SEUL TROU... ON REGARDE DIRECTEMENT 101 : C LES POSSIBILITES DE COUPE 102 : C 103 : IF(NTROU.EQ.1)GOTO 100 104 : C 105 : DO JE1=1,NTROU-1 106 : WORK1=TWORK(JE1) 107 : NPTO1=WORK1.XYC(/2) 108 : DO JE2=JE1+1,NTROU 109 : WORK2=TWORK(JE2) 110 : NPTO2=WORK2.XYC(/2) 111 : DO JE3=1,NPTO1 112 : XX=WORK1.XYC(1,JE3) 113 : YY=WORK1.XYC(2,JE3) 114 : DO JE4=1,NPTO2 115 : DO JE5=1,2 116 : XY(JE5)=WORK2.XYC(JE5,JE4) 117 : ENDDO 118 : DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2) 119 : IF(DIS.LT.TOL)THEN 120 : C 121 : C WARNING ON TESTE ICI LA POSSIBILITE DE CONTACT MULTI PONCTUEL QUE L'ON 122 : C TRAITERA PAR COHALESCENCE 123 : C 124 : IF(NCONNE(JE1).GT.0)THEN 125 : DO JE6=1,NCONNE(JE1) 126 : IF(CONNEC(2,JE6,JE1).EQ.JE2)GOTO 300 127 : ENDDO 128 : ENDIF 129 : C 130 : NCONNE(JE1)=NCONNE(JE1)+1 131 : CONNEC(1,NCONNE(JE1),JE1)=JE3 132 : CONNEC(2,NCONNE(JE1),JE1)=JE2 133 : CONNEC(3,NCONNE(JE1),JE1)=JE4 134 : NCONNE(JE2)=NCONNE(JE2)+1 135 : CONNEC(1,NCONNE(JE2),JE2)=JE4 136 : CONNEC(2,NCONNE(JE2),JE2)=JE1 137 : CONNEC(3,NCONNE(JE2),JE2)=JE3 138 : ENDIF 139 : ENDDO 140 : ENDDO 141 : ENDDO 142 : ENDDO 143 : C 144 : C SI IL N'Y A QUE 2 TROUS, ON SAUTE DIRECTEMENT AUX CYCLES EXTERNES 145 : C 146 : IF(NTROU.EQ.2)GOTO 100 147 : C 148 : C ON REGARDE LE NB DE TROU EN CONTACT AVEC AU MOINS 2 AUTRES 149 : C 150 : ICONT2=0 151 : DO JE1=1,NTROU 152 : IF(NCONNE(JE1).GE.2)THEN 153 : ICONT2=ICONT2+1 154 : NINDEX(ICONT2)=JE1 155 : ENDIF 156 : ENDDO 157 : C 158 : C SI CE NB EST PLUS PETIT QUE 3, ALORS ON PASSE AUX CYCLES EXTERNES 159 : C 160 : IF(ICONT2.LT.3)GOTO 100 161 : C 162 : C SINON ON FORME LES CYCLES EN DONNANT COMME RACINE, SUCCESSIVEMENT, 163 : C LES ICONT2-2 PREMIERS TROUS AYANT 2 VOISINS 164 : C 165 : DO 3 IE3=1,ICONT2-2 166 : C 167 : C ON CHERCHE A FORMER LES CYCLES A PARTIR DES VOISINS DU PREMIER 168 : C TROU 169 : C 170 : ITROU=1 171 : NCYCLE(1,ITROU)=0 172 : NCYCLE(2,ITROU)=NINDEX(IE3) 173 : NCYCLE(3,ITROU)=0 174 : 2 CONTINUE 175 : C 176 : C 1) ON A TOUT INSPECTE SANS RIEN TROUVE (RETOUR AU NIVEAU 0) 177 : C ---> ON PASSE A LA RACINE SUIVANTE 178 : C 179 : IF(ITROU.EQ.0)THEN 180 : GOTO 3 181 : ENDIF 182 : C 183 : C 2) ON PASSE AU VOISIN SUIVANT DU TROU DU NIVEAU COURANT 184 : C SI IL N'Y EN A PAS ON RETOURNE AU NIVEAU PRECEDENT 185 : C 186 : NCYCLE(3,ITROU)=NCYCLE(3,ITROU)+1 187 : IF(NCYCLE(3,ITROU).GT.NCONNE(NCYCLE(2,ITROU)))THEN 188 : ITROU=ITROU-1 189 : GOTO 2 190 : ENDIF 191 : C 192 : C 3) ON RECUPERE LE NUMERO DU VOISIN 193 : C SI LE VOISIN EST EGAL AU TROU PARENT ON PASSE 194 : C SI LE VOISIN A MOINS DE 2 VOISINS ON PASSE 195 : C SI LE VOISIN EST LE TROU NO.1 ON A IDENTIFIE LE CYCLE 196 : C SINON, LE VOISIN DEVIENT LE TROU DE NIVEAU SUIVANT ET ON CONTINUE 197 : C 198 : IVOIS=CONNEC(2,NCYCLE(3,ITROU),NCYCLE(2,ITROU)) 199 : IF(IVOIS.EQ.NCYCLE(1,ITROU))GOTO 2 200 : IF(NCONNE(IVOIS).LT.2)GOTO 2 201 : C 202 : C WARNING: SI ON A FINI LA BOUCLE, IL FAUT LA VALIDER... C.A.D. QU'IL FAUT 203 : C QU'IL Y EST AU MOINS 3 TROUS NON PARASITES... 204 : C 205 : C IF(IVOIS.EQ.NINDEX(IE3))GOTO 31 206 : IF(IVOIS.EQ.NINDEX(IE3))THEN 207 : NCYCLE(1,1)=NCYCLE(2,ITROU) 208 : IITROU=0 209 : DO JE1=1,ITROU 210 : IPAREN=NCYCLE(1,JE1) 211 : ICOURA=NCYCLE(2,JE1) 212 : IF(JE1.EQ.ITROU)THEN 213 : IENFAN=NINDEX(IE3) 214 : ELSE 215 : IENFAN=NCYCLE(2,JE1+1) 216 : ENDIF 217 : IPSTAR=0 218 : IPFIN=0 219 : DO JE2=1,NCONNE(ICOURA) 220 : IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 221 : 1 IPSTAR=CONNEC(1,JE2,ICOURA) 222 : IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 223 : 1 IPFIN=CONNEC(1,JE2,ICOURA) 224 : ENDDO 225 : IF(IPSTAR.EQ.IPFIN)THEN 226 : NCYCLE(2,JE1)=-NCYCLE(2,JE1) 227 : ELSE 228 : IITROU=IITROU+1 229 : ENDIF 230 : ENDDO 231 : IF(IITROU.GE.3)THEN 232 : GOTO 31 233 : ELSE 234 : DO JE1=1,ITROU 235 : NCYCLE(2,JE1)=ABS(NCYCLE(2,JE1)) 236 : ENDDO 237 : GOTO 2 238 : ENDIF 239 : ENDIF 240 : C 241 : C FIN VALIDATION 242 : C 243 : ITROU=ITROU+1 244 : NCYCLE(1,ITROU)=NCYCLE(2,ITROU-1) 245 : NCYCLE(2,ITROU)=IVOIS 246 : NCYCLE(3,ITROU)=0 247 : GOTO 2 248 : C 249 : 3 CONTINUE 250 : C 251 : C SI ON EST LA, C'EST QU'IL N'Y A PAS DE CYCLE INTERNE ET ON PASSE 252 : C AUX CYCLES EXTERNES 253 : C 254 : GOTO 100 255 : C 256 : C C'EST LA QUE L'ON SORT EN CAS DE CYCLE EN COMPLETANT NCYCLE(1,1)... 257 : C 258 : C31 NCYCLE(1,1)=NCYCLE(2,ITROU) 259 : 31 CONTINUE 260 : C 261 : C CREATION DU NOUVEAU TROU ET DE LA NOUVELLE FACE 262 : C 263 : C 1) CREATION DU COUNTOUR 264 : C 265 : NPTO=0 266 : SEGINI,WORK 267 : C 268 : C 2) BOUCLE SUR LES TROU DANS UN SENS 269 : C 270 : DO 4 JE1=1,ITROU 271 : C 272 : C 3) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS 273 : C 274 : IPAREN=NCYCLE(1,JE1) 275 : ICOURA=NCYCLE(2,JE1) 276 : IF(ICOURA.LT.0)GOTO 4 277 : IF(JE1.EQ.ITROU)THEN 278 : IENFAN=NINDEX(IE3) 279 : ELSE 280 : IENFAN=ABS(NCYCLE(2,JE1+1)) 281 : ENDIF 282 : IPSTAR=0 283 : IPFIN=0 284 : DO JE2=1,NCONNE(ICOURA) 285 : IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 286 : 1 IPSTAR=CONNEC(1,JE2,ICOURA) 287 : IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 288 : 1 IPFIN =CONNEC(1,JE2,ICOURA) 289 : ENDDO 290 : IF(IPSTAR*IPFIN.EQ.0)THEN 291 : IRAISO=1 292 : SEGSUP,WORK 293 : GOTO 9999 294 : ENDIF 295 : C 296 : C 4) ON ELIMINE LE CAS D'UN TROU PARASITE EN CONTACT PONCTUEL AU PT DE 297 : C CONTACT ENTRE 2 "VRAIS" VOISINS 298 : C 299 : C IF(IPSTAR.EQ.IPFIN)THEN 300 : C NCYCLE(2,JE1)=-NCYCLE(2,JE1) 301 : C GOTO 4 302 : C ENDIF 303 : C 304 : C 5) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN) 305 : C 306 : WORK1=TWORK(ICOURA) 307 : NPTO1=WORK1.XYC(/2) 308 : NPTO2=IPFIN-IPSTAR 309 : IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1 310 : NPTO=NPTO+NPTO2 311 : SEGADJ,WORK 312 : IPCOUR=IPFIN 313 : DO JE2=1,NPTO2 314 : IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1 315 : XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR) 316 : XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR) 317 : DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR) 318 : ENDDO 319 : 4 CONTINUE 320 : C 321 : C 6) NOUVEAU CONTOUR DANS WORK3 322 : C 323 : WORK3=WORK 324 : C 325 : C 7) CREATION DU CONTOUR 326 : C 327 : NPTO=0 328 : SEGINI,WORK 329 : C 330 : C 8) BOUCLE SUR LES TROU DANS L'AUTRE SENS 331 : C 332 : DO 5 JE1=ITROU,1,-1 333 : C 334 : C 9) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS 335 : C (ON ECHANGE LE ROLE DE IPFIN ET IPSTAR) 336 : C 337 : IPAREN=NCYCLE(1,JE1) 338 : ICOURA=NCYCLE(2,JE1) 339 : IF(ICOURA.LT.0)GOTO 5 340 : IF(JE1.EQ.ITROU)THEN 341 : IENFAN=NINDEX(IE3) 342 : ELSE 343 : IENFAN=ABS(NCYCLE(2,JE1+1)) 344 : ENDIF 345 : IPSTAR=0 346 : IPFIN=0 347 : DO JE2=1,NCONNE(ICOURA) 348 : IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 349 : 1 IPFIN=CONNEC(1,JE2,ICOURA) 350 : IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 351 : 1 IPSTAR=CONNEC(1,JE2,ICOURA) 352 : ENDDO 353 : IF(IPSTAR*IPFIN.EQ.0)THEN 354 : IRAISO=2 355 : SEGSUP,WORK,WORK3 356 : GOTO 9999 357 : ENDIF 358 : C 359 : C 10) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN) 360 : C 361 : WORK1=TWORK(ICOURA) 362 : NPTO1=WORK1.XYC(/2) 363 : NPTO2=IPFIN-IPSTAR 364 : IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1 365 : NPTO=NPTO+NPTO2 366 : SEGADJ,WORK 367 : IPCOUR=IPFIN 368 : DO JE2=1,NPTO2 369 : IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1 370 : XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR) 371 : XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR) 372 : DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR) 373 : ENDDO 374 : 5 CONTINUE 375 : C 376 : C 11) NOUVEAU CONTOUR DANS WORK2 377 : C 378 : WORK2=WORK 379 : C 380 : C 12) ON REGARDE L'ORIENTATION DE WORK2 ET WORK3 381 : C WORK2 SERA LE TROU ET WORK3 LA NOUVELLE FACE 382 : C 383 : NPTO2=WORK2.XYC(/2) 383 : CALL J3ORIE(0,WORK2.XYC,WORK2.DENS,NPTO2,IORI2,TOL,IRET) 384 : IF(IRET.NE.0)THEN 385 : IRAISO=3 386 : SEGSUP,WORK2,WORK3 387 : GOTO 9999 388 : ENDIF 389 : NPTO3=WORK3.XYC(/2) 389 : CALL J3ORIE(0,WORK3.XYC,WORK3.DENS,NPTO3,IORI3,TOL,IRET) 390 : IF(IRET.NE.0)THEN 391 : IRAISO=4 392 : SEGSUP,WORK2,WORK3 393 : GOTO 9999 394 : ENDIF 395 : IF(IORI2*IORI3.EQ.1)THEN 396 : IRAISO=5 397 : SEGSUP,WORK2,WORK3 398 : GOTO 9999 399 : ENDIF 400 : IF(IORI2.EQ.1)THEN 401 : WORK=WORK3 402 : WORK3=WORK2 403 : WORK2=WORK 404 : ENDIF 405 : C 406 : C 13) ON AJUSTE LES TROUS (ON SUPRIME CEUX QUI ONT EFFECTIVEMENT 407 : C COALESCE 408 : C 409 : WORK=TWORK(NINDEX(IE3)) 410 : SEGSUP,WORK 411 : TWORK(NINDEX(IE3))=WORK2 412 : DO JE1=2,ITROU 413 : ICOURA=NCYCLE(2,JE1) 414 : IF(ICOURA.GT.0)THEN 415 : WORK=TWORK(ICOURA) 416 : IF(WORK.NE.0)THEN 417 : SEGSUP,WORK 418 : TWORK(ICOURA)=0 419 : ENDIF 420 : ENDIF 421 : ENDDO 422 : C 423 : C 14) ET LA NOUVELLE FACE (A VOIR LE FORMAT) 424 : C 425 : NFACE=1 426 : SEGINI,VWORK2 427 : NTROU=0 428 : SEGINI,WWORK1 429 : WWORK1.FWORK=WORK3 430 : VWORK2.FWWORK(1)=WWORK1 430 : C CALL J3MUFA(VWORK2,TOL,IRET) 431 : C 432 : C 15) TRANSFERT DES TROUS DE LA FACE COURANTE DANS LA NOUVELLE 433 : C QUE L'ON AJOUTE AU BLOCK COURRANT 434 : C 434 : CALL J3HEAD(WWORK,VWORK2) 434 : CALL J3COAK(WWORK,VWORK2,TOL,IRET) 435 : IF(IRET.NE.0)THEN 436 : IRAISO=4 437 : SEGSUP,WORK2,WORK3,VWORK2,WWORK1 438 : GOTO 9999 439 : ENDIF 440 : NFACE=NFACF+1 441 : SEGADJ,VWORK 442 : FWWORK(NFACE)=VWORK2.FWWORK(1) 443 : C 444 : C 16) ON AJUSTE LA FACE COURRANTE 445 : C 445 : CALL J3REDU(WWORK) 446 : C 447 : C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2 448 : C 449 : SEGSUP,WCYCL,VWORK2 450 : IE2=IE2-1 451 : NFACF=NFACE 452 : GOTO 1000 453 : C 454 : C DEBUT DE CYCLE EXTERNE 455 : C 456 : 100 CONTINUE 457 : C 458 : C ON COMPLETE QUI TOUCHE QUOI AVEC LA DERNIERE FACE: LE CONTOUR EXTE 459 : C ICI, ON CHERCHE AU DELA DE 1 PT CAR UN TROU FORME PAR COHALESCENCE 460 : C CYCLIQUE PEUT PRESENTE CETTE PATHOLOGIE 461 : C 462 : NCONNE(NTROV)=0 463 : WORK1=FWORK 464 : NPTO1=WORK1.XYC(/2) 465 : DO JE2=1,NTROU 466 : WORK2=TWORK(JE2) 467 : NPTO2=WORK2.XYC(/2) 468 : DO JE3=1,NPTO1 469 : XX=WORK1.XYC(1,JE3) 470 : YY=WORK1.XYC(2,JE3) 471 : DO JE4=1,NPTO2 472 : DO JE5=1,2 473 : XY(JE5)=WORK2.XYC(JE5,JE4) 474 : ENDDO 475 : DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2) 476 : IF(DIS.LT.TOL)THEN 477 : NCONNE(NTROV)=NCONNE(NTROV)+1 478 : CONNEC(1,NCONNE(NTROV),NTROV)=JE3 479 : CONNEC(2,NCONNE(NTROV),NTROV)=JE2 480 : CONNEC(3,NCONNE(NTROV),NTROV)=JE4 481 : NCONNE(JE2)=NCONNE(JE2)+1 482 : CONNEC(1,NCONNE(JE2),JE2)=JE4 483 : CONNEC(2,NCONNE(JE2),JE2)=NTROV 484 : CONNEC(3,NCONNE(JE2),JE2)=JE3 485 : ENDIF 486 : ENDDO 487 : ENDDO 488 : ENDDO 489 : C 490 : C SI LE CONTOUR EXTE N'EST PAS EN CONTACT AVEC AU MOINS 2 TROUS ALORS ON PASSE 491 : C 492 : IF(NCONNE(NTROV).LT.2)THEN 493 : SEGSUP,WCYCL 494 : GOTO 1000 495 : ENDIF 496 : C 497 : C SI L'UN DES TROUS EST EN BI-CONTACT AVEC LE CONTOUR EXTE, ON SAUTE 498 : C DIRECTEMENT A LA COUPE SANS FORMER D'ARBRE 499 : C 500 : DO JE1=1,NTROU 501 : NVOIS1=0 502 : IF(NCONNE(JE1).GT.0)THEN 503 : DO JE2=1,NCONNE(JE1) 504 : IF(CONNEC(2,JE2,JE1).EQ.NTROV)NVOIS1=NVOIS1+1 505 : ENDDO 506 : ENDIF 507 : IF(NVOIS1.GE.2)THEN 508 : WORK2=TWORK(JE1) 509 : TWORK(JE1)=0 510 : GOTO 200 511 : ENDIF 512 : ENDDO 513 : C 514 : C RECHERCHE DE CYCLE AVEC LE CONTOUR EXTERIEUR COMME RACINE 515 : C 516 : ITROU=1 517 : NCYCLE(1,ITROU)=0 518 : NCYCLE(2,ITROU)=NTROV 519 : NCYCLE(3,ITROU)=0 520 : 102 CONTINUE 521 : C 522 : C 1) ON A TOUT INSPECTE SANS RIEN TROUVE (RETOUR AU NIVEAU 0) 523 : C ---> ON PASSE A LA FACE SUIVANTE 524 : C 525 : IF(ITROU.EQ.0)THEN 526 : SEGSUP,WCYCL 527 : GOTO 1000 528 : ENDIF 529 : C 530 : C 2) ON PASSE AU VOISIN SUIVANT DU TROU DU NIVEAU COURANT 531 : C SI IL N'Y EN A PAS ON RETOURNE AU NIVEAU PRECEDENT 532 : C 533 : NCYCLE(3,ITROU)=NCYCLE(3,ITROU)+1 534 : IF(NCYCLE(3,ITROU).GT.NCONNE(NCYCLE(2,ITROU)))THEN 535 : ITROU=ITROU-1 536 : GOTO 102 537 : ENDIF 538 : C 539 : C 3) ON RECUPERE LE NUMERO DU VOISIN 540 : C SI LE VOISIN EST EGAL AU TROU PARENT ON PASSE 541 : C SI LE VOISIN A MOINS DE 2 VOISINS ON PASSE 542 : C SI LE VOISIN EST LE TROU NO.1 ON A IDENTIFIE LE CYCLE 543 : C SINON, LE VOISIN DEVIENT LE TROU DE NIVEAU SUIVANT ET ON CONTINUE 544 : C 545 : IVOIS=CONNEC(2,NCYCLE(3,ITROU),NCYCLE(2,ITROU)) 546 : IF(IVOIS.EQ.NCYCLE(1,ITROU))GOTO 102 547 : IF(NCONNE(IVOIS).LT.2)GOTO 102 548 : 549 : C 550 : C WARNING: SI ON A FINI LA BOUCLE, IL FAUT LA VALIDER... C.A.D. QU'IL FAUT 551 : C QU'IL Y EST AU MOINS 3 TROUS NON PARASITES... 552 : C 553 : C IF(IVOIS.EQ.NTROV)GOTO 104 554 : IF(IVOIS.EQ.NTROV)THEN 555 : NCYCLE(1,1)=NCYCLE(2,ITROU) 556 : IITROU=0 557 : DO JE1=1,ITROU 558 : IPAREN=NCYCLE(1,JE1) 559 : ICOURA=NCYCLE(2,JE1) 560 : IF(JE1.EQ.ITROU)THEN 561 : IENFAN=NINDEX(IE3) 562 : ELSE 563 : IENFAN=NCYCLE(2,JE1+1) 564 : ENDIF 565 : IPSTAR=0 566 : IPFIN=0 567 : DO JE2=1,NCONNE(ICOURA) 568 : IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 569 : 1 IPSTAR=CONNEC(1,JE2,ICOURA) 570 : IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 571 : 1 IPFIN=CONNEC(1,JE2,ICOURA) 572 : ENDDO 573 : IF(IPSTAR.EQ.IPFIN)THEN 574 : NCYCLE(2,JE1)=-NCYCLE(2,JE1) 575 : ELSE 576 : IITROU=IITROU+1 577 : ENDIF 578 : ENDDO 579 : IF(IITROU.GE.3)THEN 580 : GOTO 104 581 : ELSE 582 : DO JE1=1,ITROU 583 : NCYCLE(2,JE1)=ABS(NCYCLE(2,JE1)) 584 : ENDDO 585 : GOTO 102 586 : ENDIF 587 : ENDIF 588 : C 589 : C FIN VALIDATION 590 : C 591 : ITROU=ITROU+1 592 : NCYCLE(1,ITROU)=NCYCLE(2,ITROU-1) 593 : NCYCLE(2,ITROU)=IVOIS 594 : NCYCLE(3,ITROU)=0 595 : GOTO 102 596 : C 597 : C C'EST LA QUE L'ON SORT EN CAS DE CYCLE EN COMPLETANT NCYCLE(1,1)... 598 : C 599 : C104 NCYCLE(1,1)=NCYCLE(2,ITROU) 600 : 104 CONTINUE 601 : C 602 : C COHALESCENCE PAR LA POINTE DES TROUS QUI FORMENT LE CYCLE 603 : C 604 : C 605 : C 1) CREATION DU CONTOUR 606 : C 607 : NPTO=0 608 : SEGINI,WORK 609 : C 610 : C 2) BOUCLE SUR LES TROU DANS UN SENS 611 : C 612 : DO 105 JE1=2,ITROU 613 : C 614 : C 3) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS 615 : C 616 : IPAREN=NCYCLE(1,JE1) 617 : ICOURA=NCYCLE(2,JE1) 618 : IF(ICOURA.LT.0)GOTO 105 619 : IF(JE1.EQ.ITROU)THEN 620 : IENFAN=NTROV 621 : ELSE 622 : IENFAN=ABS(NCYCLE(2,JE1+1)) 623 : ENDIF 624 : IPSTAR=0 625 : IPFIN=0 626 : DO JE2=1,NCONNE(ICOURA) 627 : IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 628 : 1 IPSTAR=CONNEC(1,JE2,ICOURA) 629 : IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 630 : 1 IPFIN=CONNEC(1,JE2,ICOURA) 631 : ENDDO 632 : IF(IPSTAR*IPFIN.EQ.0)THEN 633 : IRAISO=10 634 : SEGSUP,WORK 635 : GOTO 9999 636 : ENDIF 637 : C 638 : C 4) ON ELIMINE LE CAS D'UN TROU PARASITE EN CONTACT PONCTUEL AU PT DE 639 : C CONTACT ENTRE 2 "VRAIS" VOISINS 640 : C 641 : C IF(IPSTAR.EQ.IPFIN)THEN 642 : C NCYCLE(2,JE1)=-NCYCLE(2,JE1) 643 : C GOTO 105 644 : C ENDIF 645 : C 646 : C 5) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN) 647 : C 648 : WORK1=TWORK(ICOURA) 649 : NPTO1=WORK1.XYC(/2) 650 : NPTO2=IPFIN-IPSTAR 651 : IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1 652 : NPTO=NPTO+NPTO2 653 : SEGADJ,WORK 654 : IPCOUR=IPFIN 655 : DO JE2=1,NPTO2 656 : IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1 657 : XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR) 658 : XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR) 659 : DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR) 660 : ENDDO 661 : 105 CONTINUE 662 : 663 : C 664 : C 6) BOUCLE SUR LES TROU DANS L'AUTRE SENS 665 : C 666 : DO 106 JE1=ITROU,2,-1 667 : C 668 : C 7) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS 669 : C (ON ECHANGE LE ROLE DE IPFIN ET IPSTAR) 670 : C 671 : IPAREN=NCYCLE(1,JE1) 672 : ICOURA=NCYCLE(2,JE1) 673 : IF(ICOURA.LT.0)GOTO 106 674 : IF(JE1.EQ.ITROU)THEN 675 : IENFAN=NTROV 676 : ELSE 677 : IENFAN=ABS(NCYCLE(2,JE1+1)) 678 : ENDIF 679 : IPSTAR=0 680 : IPFIN=0 681 : DO JE2=1,NCONNE(ICOURA) 682 : IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 683 : 1 IPFIN=CONNEC(1,JE2,ICOURA) 684 : IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 685 : 1 IPSTAR=CONNEC(1,JE2,ICOURA) 686 : ENDDO 687 : IF(IPSTAR*IPFIN.EQ.0)THEN 688 : IRAISO=11 689 : SEGSUP,WORK 690 : GOTO 9999 691 : ENDIF 692 : C 693 : C 8) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN) 694 : C 695 : WORK1=TWORK(ICOURA) 696 : NPTO1=WORK1.XYC(/2) 697 : NPTO2=IPFIN-IPSTAR 698 : IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1 699 : NPTO=NPTO+NPTO2 700 : SEGADJ,WORK 701 : IPCOUR=IPFIN 702 : DO JE2=1,NPTO2 703 : IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1 704 : XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR) 705 : XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR) 706 : DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR) 707 : ENDDO 708 : 106 CONTINUE 709 : C 710 : C 9) NOUVEAU CONTOUR DANS WORK2 711 : C 712 : WORK2=WORK 713 : C 714 : C 10) ON AJUSTE LES TROUS (ON SUPRIME CEUX QUI ONT EFFECTIVEMENT 715 : C COALESCE 716 : C 717 : DO JE1=1,ITROU 718 : ICOURA=NCYCLE(2,JE1) 719 : IF(ICOURA.GT.0)THEN 720 : WORK=TWORK(ICOURA) 721 : IF(WORK.NE.0)THEN 722 : SEGSUP,WORK 723 : TWORK(ICOURA)=0 724 : ENDIF 725 : ENDIF 726 : ENDDO 727 : C 728 : C COUPE: LA FACE "B" EST DANS WORK2 ET "A" DANS WWORK 729 : C 730 : C ON ORIENTE CORRECTEMENT B 731 : C ON CHERCHE LES CONNEXIONS 732 : C ON COUPE 733 : C ON NE S'OCCUPE QUE DE LA PARTIE EXTERIEURE A LA COUPE 734 : C 735 : 200 CONTINUE 735 : CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,WORK2.XYC(/2),1,TOL,IRET) 736 : IF(IRET.NE.0)THEN 737 : IRAISO=20 738 : GOTO 9999 739 : ENDIF 740 : WORK1=FWORK 740 : CALL J3COTO(WORK2,WORK1,TOL,IRET) 741 : IF(IRET.NE.0)THEN 742 : IRAISO=21 743 : GOTO 9999 744 : ENDIF 744 : CALL J3COTO(WORK1,WORK2,TOL,IRET) 745 : IF(IRET.NE.0)THEN 746 : IRAISO=22 747 : GOTO 9999 748 : ENDIF 748 : CALL J3JUNC(WORK1,WORK2,TOL,IRET) 749 : IF(IRET.NE.0)THEN 750 : IRAISO=23 751 : GOTO 9999 752 : ENDIF 752 : CALL J3JUNC(WORK2,WORK1,TOL,IRET) 753 : IF(IRET.NE.0)THEN 754 : IRAISO=24 755 : GOTO 9999 756 : ENDIF 757 : FWORK=WORK1 757 : CALL J3COUP(WWORK,WORK2,VWDUMM,VWORK2,1,TOL,IRET) 757 : CALL J3DET1(VWDUMM) 757 : CALL J3HEAD(WWORK,VWORK2) 758 : C 759 : C ON AJOUTE LES NOUVELLES FACES ET ON FLINGUE l'ANCIENNE 760 : C 761 : NFACN=VWORK2.FWWORK(/1) 762 : IF(NFACN.EQ.0)THEN 763 : IRET=IRET+1 764 : IRAISO=25 765 : GOTO 9999 766 : ENDIF 767 : WORK=FWORK 768 : SEGSUP,WWORK,WORK 769 : FWWORK(IE2)=VWORK2.FWWORK(NFACN) 770 : NFACE=NFACF+NFACN-1 771 : SEGADJ,VWORK 772 : DO JE1=1,NFACN-1 773 : FWWORK(NFACF+JE1)=VWORK2.FWWORK(JE1) 774 : ENDDO 775 : C 776 : C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2 777 : C 778 : SEGSUP,WCYCL,VWORK2 779 : IE2=IE2-1 780 : NFACF=NFACE 781 : GOTO 1000 782 : C 783 : C ON ENTRE DANS LE CAS DU CONTACT MULTI PONCTUEL ENTRE 2 TROUS JE1 ET JE2 784 : C 785 : 300 CONTINUE 786 : WORK1=TWORK(JE1) 787 : WORK2=TWORK(JE2) 788 : C 789 : C ON VERIFIE... 790 : C 790 : CALL J3COTO(WORK2,WORK1,TOL,IRET) 791 : IF(IRET.NE.0)THEN 792 : IRAISO=30 793 : GOTO 9999 794 : ENDIF 794 : CALL J3COTO(WORK1,WORK2,TOL,IRET) 795 : IF(IRET.NE.0)THEN 796 : IRAISO=31 797 : GOTO 9999 798 : ENDIF 798 : CALL J3JUNC(WORK1,WORK2,TOL,IRET) 799 : IF(IRET.NE.0)THEN 800 : IRAISO=32 801 : GOTO 9999 802 : ENDIF 802 : CALL J3JUNC(WORK2,WORK1,TOL,IRET) 803 : IF(IRET.NE.0)THEN 804 : IRAISO=33 805 : GOTO 9999 806 : ENDIF 807 : C 808 : C ON COHALESCE DANS VWORK2 809 : C 809 : CALL J3COAL(WORK1,WORK2,.FALSE.,VWORK2,NFACEA,TOL,IRET) 810 : IF(IRET.GT.0)THEN 811 : IRAISO=34 812 : GOTO 9999 813 : ELSE 814 : JUNC=WORK2.JUN 815 : IF(JUNC.NE.0)SEGSUP,JUNC 816 : SEGSUP,WORK2 817 : TWORK(JE1)=WORK1 818 : TWORK(JE2)=0 819 : ENDIF 820 : C 821 : C ON DISTRIBUE 822 : C 823 : IF(NFACEA.GT.0)THEN 823 : CALL J3HEAD(WWORK,VWORK2) 823 : CALL J3COAK(WWORK,VWORK2,TOL,IRET) 824 : ENDIF 825 : C 826 : C ON AJUSTE 827 : C 827 : CALL J3REDU(WWORK) 828 : C 829 : C ON AJOUTE LES NOUVELLES FACES 830 : C 831 : NFACN=VWORK2.FWWORK(/1) 832 : IF(NFACN.EQ.0)THEN 833 : IRET=IRET+1 834 : IRAISO=35 835 : GOTO 9999 836 : ENDIF 837 : NFACE=NFACF+NFACN 838 : SEGADJ,VWORK 839 : DO JE1=1,NFACN 840 : FWWORK(NFACF+JE1)=VWORK2.FWWORK(JE1) 841 : ENDDO 842 : C 843 : C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2 844 : C 845 : SEGSUP,WCYCL,VWORK2 846 : IE2=IE2-1 847 : NFACF=NFACE 848 : GOTO 1000 849 : C 850 : C 851 : C FIN BOUCLE FACE 852 : C 853 : 1001 CONTINUE 854 : C 855 : C FIN BOUCLE BLOCK 856 : C 857 : ENDDO 858 : C 859 : RETURN 860 : C 861 : C CONFIGURATION IMPOSSIBLE 862 : C 863 : 9999 CONTINUE 864 : IRET=IRET+1 865 : SEGSUP,WCYCL 866 : WRITE(IOIMP,*)' J3SURE: CONFIGURATION IMPOSSIBLE NO.',IRAISO 867 : RETURN 868 : C 869 : END 870 : 871 :
© Cast3M 2003 - All rights reserved.
Disclaimer