C J3SURE SOURCE CHAT 05/01/13 00:47:25 5004 SUBROUTINE J3SURE(VWORK1,IRET,TOL) C---------------------------------------------------- C ELIMINATION DES CAS TORDUS POUR SURF C QUI CREE DE NOUVELLE FACES: C C - CYCLE INTERIEUR DE TROU C - CYCLE DE TROU AVEC LE CONTOUR PRINCIPAL C C PP 12/98 C Pierre Pegon/JRC Ispra C---------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) DIMENSION XY(2) C -INC PPARAM -INC CCOPTIO C SEGMENT VWORK INTEGER FWWORK(NFACE) ENDSEGMENT POINTEUR VWORK1.VWORK,VWORK2.VWORK,VWDUMM.VWORK C SEGMENT WWORK REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3) INTEGER FWORK INTEGER TWORK(NTROU) ENDSEGMENT POINTEUR WWORK1.WWORK C SEGMENT WORK REAL*8 XYC(2,NPTO) INTEGER IST(3,NPTO) REAL*8 DENS(NPTO) INTEGER JUN ENDSEGMENT POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK C SEGMENT JUNC INTEGER CRO(2,NPTO) ENDSEGMENT C SEGMENT WCYCL C CONNEC(.,.,J)=NO DU CONTOUR CONCERNE C CONNEC(.,I,J)=IEME VOISIN DU TROU J C CONNEC(1,.,.)=NO DU POINT C CONNEC(2,.,.)=NO DU CONTOUR EN CONTACT C CONNEC(1,.,.)=NO DU POINT INTEGER CONNEC(3,NTROV,NTROV) C NCONNE(J)=NB DE VOISIN DU TROU J INTEGER NCONNE(NTROV) C NCYCLE(.,I)=NIVEAU DANS LE CYCLE DE TROU C NCYCLE(1,,)=TROU AMONT C NCYCLE(2,,)=TROU COURANT C NCYCLE(3,,)=RANG DU VOISIN COURANT INTEGER NCYCLE(3,NTROV) INTEGER NINDEX(NTROV) ENDSEGMENT C C ON RENTRE AVEC DES ENSEMBLE DE VWORK REPRESENTANT CHACUN C UN BLOCK COMPOSE DE FACE C NBLOCK=VWORK1.FWWORK(/1) C C ON BOUCLE SUR CHAQUE BLOCK C DO IE1=1,NBLOCK VWORK=VWORK1.FWWORK(IE1) NFACF=FWWORK(/1) C C ON BOUCLE SUR CHAQUE FACE (ON SIMULE DO 1000 IE2=1,NFACE C C DO 1000 IE2=1,NFACE C IE2=0 1000 IE2=IE2+1 IF (IE2.GT.NFACF)GOTO 1001 C WWORK=FWWORK(IE2) NTROU=TWORK(/1) C C S'IL Y A MOINS DE 2 TROUS, IL N'Y A PAS POSSIBILITE DE CYCLE INTE C OU EXTE ET ALORS ON NE FAIT RIEN C EN FAIT J3SURE LUI MEME PEUT CREER DES FACES AVEC UN TROU... QUI C SONT CANDIDAT A LA COUPE... C C IF(NTROU.LT.2)GOTO 1000 IF(NTROU.EQ.0)GOTO 1000 C C ON CHERCHE QUI EST EN CONTACT (PONCTUEL) AVEC QUOI C ON CHERCHE MEME AU DELA DE 1 PT [CAR LA COALESCENCE DE TROUS EN C CONTACT AVEC UN SEUL POINT PEUT CREER DU CONTACT MULTI POINT!) C NTROV=NTROU+1 SEGINI,WCYCL DO JE1=1,NTROU NCONNE(JE1)=0 ENDDO C C WARNING: S'IL N'Y A QU'UN SEUL TROU... ON REGARDE DIRECTEMENT C LES POSSIBILITES DE COUPE C IF(NTROU.EQ.1)GOTO 100 C DO JE1=1,NTROU-1 WORK1=TWORK(JE1) NPTO1=WORK1.XYC(/2) DO JE2=JE1+1,NTROU WORK2=TWORK(JE2) NPTO2=WORK2.XYC(/2) DO JE3=1,NPTO1 XX=WORK1.XYC(1,JE3) YY=WORK1.XYC(2,JE3) DO JE4=1,NPTO2 DO JE5=1,2 XY(JE5)=WORK2.XYC(JE5,JE4) ENDDO DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2) IF(DIS.LT.TOL)THEN C C WARNING ON TESTE ICI LA POSSIBILITE DE CONTACT MULTI PONCTUEL QUE L'ON C TRAITERA PAR COHALESCENCE C IF(NCONNE(JE1).GT.0)THEN DO JE6=1,NCONNE(JE1) IF(CONNEC(2,JE6,JE1).EQ.JE2)GOTO 300 ENDDO ENDIF C NCONNE(JE1)=NCONNE(JE1)+1 CONNEC(1,NCONNE(JE1),JE1)=JE3 CONNEC(2,NCONNE(JE1),JE1)=JE2 CONNEC(3,NCONNE(JE1),JE1)=JE4 NCONNE(JE2)=NCONNE(JE2)+1 CONNEC(1,NCONNE(JE2),JE2)=JE4 CONNEC(2,NCONNE(JE2),JE2)=JE1 CONNEC(3,NCONNE(JE2),JE2)=JE3 ENDIF ENDDO ENDDO ENDDO ENDDO C C SI IL N'Y A QUE 2 TROUS, ON SAUTE DIRECTEMENT AUX CYCLES EXTERNES C IF(NTROU.EQ.2)GOTO 100 C C ON REGARDE LE NB DE TROU EN CONTACT AVEC AU MOINS 2 AUTRES C ICONT2=0 DO JE1=1,NTROU IF(NCONNE(JE1).GE.2)THEN ICONT2=ICONT2+1 NINDEX(ICONT2)=JE1 ENDIF ENDDO C C SI CE NB EST PLUS PETIT QUE 3, ALORS ON PASSE AUX CYCLES EXTERNES C IF(ICONT2.LT.3)GOTO 100 C C SINON ON FORME LES CYCLES EN DONNANT COMME RACINE, SUCCESSIVEMENT, C LES ICONT2-2 PREMIERS TROUS AYANT 2 VOISINS C DO 3 IE3=1,ICONT2-2 C C ON CHERCHE A FORMER LES CYCLES A PARTIR DES VOISINS DU PREMIER C TROU C ITROU=1 NCYCLE(1,ITROU)=0 NCYCLE(2,ITROU)=NINDEX(IE3) NCYCLE(3,ITROU)=0 2 CONTINUE C C 1) ON A TOUT INSPECTE SANS RIEN TROUVE (RETOUR AU NIVEAU 0) C ---> ON PASSE A LA RACINE SUIVANTE C IF(ITROU.EQ.0)THEN GOTO 3 ENDIF C C 2) ON PASSE AU VOISIN SUIVANT DU TROU DU NIVEAU COURANT C SI IL N'Y EN A PAS ON RETOURNE AU NIVEAU PRECEDENT C NCYCLE(3,ITROU)=NCYCLE(3,ITROU)+1 IF(NCYCLE(3,ITROU).GT.NCONNE(NCYCLE(2,ITROU)))THEN ITROU=ITROU-1 GOTO 2 ENDIF C C 3) ON RECUPERE LE NUMERO DU VOISIN C SI LE VOISIN EST EGAL AU TROU PARENT ON PASSE C SI LE VOISIN A MOINS DE 2 VOISINS ON PASSE C SI LE VOISIN EST LE TROU NO.1 ON A IDENTIFIE LE CYCLE C SINON, LE VOISIN DEVIENT LE TROU DE NIVEAU SUIVANT ET ON CONTINUE C IVOIS=CONNEC(2,NCYCLE(3,ITROU),NCYCLE(2,ITROU)) IF(IVOIS.EQ.NCYCLE(1,ITROU))GOTO 2 IF(NCONNE(IVOIS).LT.2)GOTO 2 C C WARNING: SI ON A FINI LA BOUCLE, IL FAUT LA VALIDER... C.A.D. QU'IL FAUT C QU'IL Y EST AU MOINS 3 TROUS NON PARASITES... C C IF(IVOIS.EQ.NINDEX(IE3))GOTO 31 IF(IVOIS.EQ.NINDEX(IE3))THEN NCYCLE(1,1)=NCYCLE(2,ITROU) IITROU=0 DO JE1=1,ITROU IPAREN=NCYCLE(1,JE1) ICOURA=NCYCLE(2,JE1) IF(JE1.EQ.ITROU)THEN IENFAN=NINDEX(IE3) ELSE IENFAN=NCYCLE(2,JE1+1) ENDIF IPSTAR=0 IPFIN=0 DO JE2=1,NCONNE(ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 1 IPSTAR=CONNEC(1,JE2,ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 1 IPFIN=CONNEC(1,JE2,ICOURA) ENDDO IF(IPSTAR.EQ.IPFIN)THEN NCYCLE(2,JE1)=-NCYCLE(2,JE1) ELSE IITROU=IITROU+1 ENDIF ENDDO IF(IITROU.GE.3)THEN GOTO 31 ELSE DO JE1=1,ITROU NCYCLE(2,JE1)=ABS(NCYCLE(2,JE1)) ENDDO GOTO 2 ENDIF ENDIF C C FIN VALIDATION C ITROU=ITROU+1 NCYCLE(1,ITROU)=NCYCLE(2,ITROU-1) NCYCLE(2,ITROU)=IVOIS NCYCLE(3,ITROU)=0 GOTO 2 C 3 CONTINUE C C SI ON EST LA, C'EST QU'IL N'Y A PAS DE CYCLE INTERNE ET ON PASSE C AUX CYCLES EXTERNES C GOTO 100 C C C'EST LA QUE L'ON SORT EN CAS DE CYCLE EN COMPLETANT NCYCLE(1,1)... C C31 NCYCLE(1,1)=NCYCLE(2,ITROU) 31 CONTINUE C C CREATION DU NOUVEAU TROU ET DE LA NOUVELLE FACE C C 1) CREATION DU COUNTOUR C NPTO=0 SEGINI,WORK C C 2) BOUCLE SUR LES TROU DANS UN SENS C DO 4 JE1=1,ITROU C C 3) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS C IPAREN=NCYCLE(1,JE1) ICOURA=NCYCLE(2,JE1) IF(ICOURA.LT.0)GOTO 4 IF(JE1.EQ.ITROU)THEN IENFAN=NINDEX(IE3) ELSE IENFAN=ABS(NCYCLE(2,JE1+1)) ENDIF IPSTAR=0 IPFIN=0 DO JE2=1,NCONNE(ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 1 IPSTAR=CONNEC(1,JE2,ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 1 IPFIN =CONNEC(1,JE2,ICOURA) ENDDO IF(IPSTAR*IPFIN.EQ.0)THEN IRAISO=1 SEGSUP,WORK GOTO 9999 ENDIF C C 4) ON ELIMINE LE CAS D'UN TROU PARASITE EN CONTACT PONCTUEL AU PT DE C CONTACT ENTRE 2 "VRAIS" VOISINS C C IF(IPSTAR.EQ.IPFIN)THEN C NCYCLE(2,JE1)=-NCYCLE(2,JE1) C GOTO 4 C ENDIF C C 5) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN) C WORK1=TWORK(ICOURA) NPTO1=WORK1.XYC(/2) NPTO2=IPFIN-IPSTAR IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1 NPTO=NPTO+NPTO2 SEGADJ,WORK IPCOUR=IPFIN DO JE2=1,NPTO2 IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1 XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR) XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR) DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR) ENDDO 4 CONTINUE C C 6) NOUVEAU CONTOUR DANS WORK3 C WORK3=WORK C C 7) CREATION DU CONTOUR C NPTO=0 SEGINI,WORK C C 8) BOUCLE SUR LES TROU DANS L'AUTRE SENS C DO 5 JE1=ITROU,1,-1 C C 9) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS C (ON ECHANGE LE ROLE DE IPFIN ET IPSTAR) C IPAREN=NCYCLE(1,JE1) ICOURA=NCYCLE(2,JE1) IF(ICOURA.LT.0)GOTO 5 IF(JE1.EQ.ITROU)THEN IENFAN=NINDEX(IE3) ELSE IENFAN=ABS(NCYCLE(2,JE1+1)) ENDIF IPSTAR=0 IPFIN=0 DO JE2=1,NCONNE(ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 1 IPFIN=CONNEC(1,JE2,ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 1 IPSTAR=CONNEC(1,JE2,ICOURA) ENDDO IF(IPSTAR*IPFIN.EQ.0)THEN IRAISO=2 SEGSUP,WORK,WORK3 GOTO 9999 ENDIF C C 10) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN) C WORK1=TWORK(ICOURA) NPTO1=WORK1.XYC(/2) NPTO2=IPFIN-IPSTAR IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1 NPTO=NPTO+NPTO2 SEGADJ,WORK IPCOUR=IPFIN DO JE2=1,NPTO2 IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1 XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR) XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR) DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR) ENDDO 5 CONTINUE C C 11) NOUVEAU CONTOUR DANS WORK2 C WORK2=WORK C C 12) ON REGARDE L'ORIENTATION DE WORK2 ET WORK3 C WORK2 SERA LE TROU ET WORK3 LA NOUVELLE FACE C NPTO2=WORK2.XYC(/2) CALL J3ORIE(0,WORK2.XYC,WORK2.DENS,NPTO2,IORI2,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=3 SEGSUP,WORK2,WORK3 GOTO 9999 ENDIF NPTO3=WORK3.XYC(/2) CALL J3ORIE(0,WORK3.XYC,WORK3.DENS,NPTO3,IORI3,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=4 SEGSUP,WORK2,WORK3 GOTO 9999 ENDIF IF(IORI2*IORI3.EQ.1)THEN IRAISO=5 SEGSUP,WORK2,WORK3 GOTO 9999 ENDIF IF(IORI2.EQ.1)THEN WORK=WORK3 WORK3=WORK2 WORK2=WORK ENDIF C C 13) ON AJUSTE LES TROUS (ON SUPRIME CEUX QUI ONT EFFECTIVEMENT C COALESCE C WORK=TWORK(NINDEX(IE3)) SEGSUP,WORK TWORK(NINDEX(IE3))=WORK2 DO JE1=2,ITROU ICOURA=NCYCLE(2,JE1) IF(ICOURA.GT.0)THEN WORK=TWORK(ICOURA) IF(WORK.NE.0)THEN SEGSUP,WORK TWORK(ICOURA)=0 ENDIF ENDIF ENDDO C C 14) ET LA NOUVELLE FACE (A VOIR LE FORMAT) C NFACE=1 SEGINI,VWORK2 NTROU=0 SEGINI,WWORK1 WWORK1.FWORK=WORK3 VWORK2.FWWORK(1)=WWORK1 C CALL J3MUFA(VWORK2,TOL,IRET) C C 15) TRANSFERT DES TROUS DE LA FACE COURANTE DANS LA NOUVELLE C QUE L'ON AJOUTE AU BLOCK COURRANT C CALL J3HEAD(WWORK,VWORK2) CALL J3COAK(WWORK,VWORK2,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=4 SEGSUP,WORK2,WORK3,VWORK2,WWORK1 GOTO 9999 ENDIF NFACE=NFACF+1 SEGADJ,VWORK FWWORK(NFACE)=VWORK2.FWWORK(1) C C 16) ON AJUSTE LA FACE COURRANTE C CALL J3REDU(WWORK) C C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2 C SEGSUP,WCYCL,VWORK2 IE2=IE2-1 NFACF=NFACE GOTO 1000 C C DEBUT DE CYCLE EXTERNE C 100 CONTINUE C C ON COMPLETE QUI TOUCHE QUOI AVEC LA DERNIERE FACE: LE CONTOUR EXTE C ICI, ON CHERCHE AU DELA DE 1 PT CAR UN TROU FORME PAR COHALESCENCE C CYCLIQUE PEUT PRESENTE CETTE PATHOLOGIE C NCONNE(NTROV)=0 WORK1=FWORK NPTO1=WORK1.XYC(/2) DO JE2=1,NTROU WORK2=TWORK(JE2) NPTO2=WORK2.XYC(/2) DO JE3=1,NPTO1 XX=WORK1.XYC(1,JE3) YY=WORK1.XYC(2,JE3) DO JE4=1,NPTO2 DO JE5=1,2 XY(JE5)=WORK2.XYC(JE5,JE4) ENDDO DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2) IF(DIS.LT.TOL)THEN NCONNE(NTROV)=NCONNE(NTROV)+1 CONNEC(1,NCONNE(NTROV),NTROV)=JE3 CONNEC(2,NCONNE(NTROV),NTROV)=JE2 CONNEC(3,NCONNE(NTROV),NTROV)=JE4 NCONNE(JE2)=NCONNE(JE2)+1 CONNEC(1,NCONNE(JE2),JE2)=JE4 CONNEC(2,NCONNE(JE2),JE2)=NTROV CONNEC(3,NCONNE(JE2),JE2)=JE3 ENDIF ENDDO ENDDO ENDDO C C SI LE CONTOUR EXTE N'EST PAS EN CONTACT AVEC AU MOINS 2 TROUS ALORS ON PASSE C IF(NCONNE(NTROV).LT.2)THEN SEGSUP,WCYCL GOTO 1000 ENDIF C C SI L'UN DES TROUS EST EN BI-CONTACT AVEC LE CONTOUR EXTE, ON SAUTE C DIRECTEMENT A LA COUPE SANS FORMER D'ARBRE C DO JE1=1,NTROU NVOIS1=0 IF(NCONNE(JE1).GT.0)THEN DO JE2=1,NCONNE(JE1) IF(CONNEC(2,JE2,JE1).EQ.NTROV)NVOIS1=NVOIS1+1 ENDDO ENDIF IF(NVOIS1.GE.2)THEN WORK2=TWORK(JE1) TWORK(JE1)=0 GOTO 200 ENDIF ENDDO C C RECHERCHE DE CYCLE AVEC LE CONTOUR EXTERIEUR COMME RACINE C ITROU=1 NCYCLE(1,ITROU)=0 NCYCLE(2,ITROU)=NTROV NCYCLE(3,ITROU)=0 102 CONTINUE C C 1) ON A TOUT INSPECTE SANS RIEN TROUVE (RETOUR AU NIVEAU 0) C ---> ON PASSE A LA FACE SUIVANTE C IF(ITROU.EQ.0)THEN SEGSUP,WCYCL GOTO 1000 ENDIF C C 2) ON PASSE AU VOISIN SUIVANT DU TROU DU NIVEAU COURANT C SI IL N'Y EN A PAS ON RETOURNE AU NIVEAU PRECEDENT C NCYCLE(3,ITROU)=NCYCLE(3,ITROU)+1 IF(NCYCLE(3,ITROU).GT.NCONNE(NCYCLE(2,ITROU)))THEN ITROU=ITROU-1 GOTO 102 ENDIF C C 3) ON RECUPERE LE NUMERO DU VOISIN C SI LE VOISIN EST EGAL AU TROU PARENT ON PASSE C SI LE VOISIN A MOINS DE 2 VOISINS ON PASSE C SI LE VOISIN EST LE TROU NO.1 ON A IDENTIFIE LE CYCLE C SINON, LE VOISIN DEVIENT LE TROU DE NIVEAU SUIVANT ET ON CONTINUE C IVOIS=CONNEC(2,NCYCLE(3,ITROU),NCYCLE(2,ITROU)) IF(IVOIS.EQ.NCYCLE(1,ITROU))GOTO 102 IF(NCONNE(IVOIS).LT.2)GOTO 102 C C WARNING: SI ON A FINI LA BOUCLE, IL FAUT LA VALIDER... C.A.D. QU'IL FAUT C QU'IL Y EST AU MOINS 3 TROUS NON PARASITES... C C IF(IVOIS.EQ.NTROV)GOTO 104 IF(IVOIS.EQ.NTROV)THEN NCYCLE(1,1)=NCYCLE(2,ITROU) IITROU=0 DO JE1=1,ITROU IPAREN=NCYCLE(1,JE1) ICOURA=NCYCLE(2,JE1) IF(JE1.EQ.ITROU)THEN IENFAN=NINDEX(IE3) ELSE IENFAN=NCYCLE(2,JE1+1) ENDIF IPSTAR=0 IPFIN=0 DO JE2=1,NCONNE(ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 1 IPSTAR=CONNEC(1,JE2,ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 1 IPFIN=CONNEC(1,JE2,ICOURA) ENDDO IF(IPSTAR.EQ.IPFIN)THEN NCYCLE(2,JE1)=-NCYCLE(2,JE1) ELSE IITROU=IITROU+1 ENDIF ENDDO IF(IITROU.GE.3)THEN GOTO 104 ELSE DO JE1=1,ITROU NCYCLE(2,JE1)=ABS(NCYCLE(2,JE1)) ENDDO GOTO 102 ENDIF ENDIF C C FIN VALIDATION C ITROU=ITROU+1 NCYCLE(1,ITROU)=NCYCLE(2,ITROU-1) NCYCLE(2,ITROU)=IVOIS NCYCLE(3,ITROU)=0 GOTO 102 C C C'EST LA QUE L'ON SORT EN CAS DE CYCLE EN COMPLETANT NCYCLE(1,1)... C C104 NCYCLE(1,1)=NCYCLE(2,ITROU) 104 CONTINUE C C COHALESCENCE PAR LA POINTE DES TROUS QUI FORMENT LE CYCLE C C C 1) CREATION DU CONTOUR C NPTO=0 SEGINI,WORK C C 2) BOUCLE SUR LES TROU DANS UN SENS C DO 105 JE1=2,ITROU C C 3) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS C IPAREN=NCYCLE(1,JE1) ICOURA=NCYCLE(2,JE1) IF(ICOURA.LT.0)GOTO 105 IF(JE1.EQ.ITROU)THEN IENFAN=NTROV ELSE IENFAN=ABS(NCYCLE(2,JE1+1)) ENDIF IPSTAR=0 IPFIN=0 DO JE2=1,NCONNE(ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 1 IPSTAR=CONNEC(1,JE2,ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 1 IPFIN=CONNEC(1,JE2,ICOURA) ENDDO IF(IPSTAR*IPFIN.EQ.0)THEN IRAISO=10 SEGSUP,WORK GOTO 9999 ENDIF C C 4) ON ELIMINE LE CAS D'UN TROU PARASITE EN CONTACT PONCTUEL AU PT DE C CONTACT ENTRE 2 "VRAIS" VOISINS C C IF(IPSTAR.EQ.IPFIN)THEN C NCYCLE(2,JE1)=-NCYCLE(2,JE1) C GOTO 105 C ENDIF C C 5) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN) C WORK1=TWORK(ICOURA) NPTO1=WORK1.XYC(/2) NPTO2=IPFIN-IPSTAR IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1 NPTO=NPTO+NPTO2 SEGADJ,WORK IPCOUR=IPFIN DO JE2=1,NPTO2 IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1 XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR) XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR) DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR) ENDDO 105 CONTINUE C C 6) BOUCLE SUR LES TROU DANS L'AUTRE SENS C DO 106 JE1=ITROU,2,-1 C C 7) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS C (ON ECHANGE LE ROLE DE IPFIN ET IPSTAR) C IPAREN=NCYCLE(1,JE1) ICOURA=NCYCLE(2,JE1) IF(ICOURA.LT.0)GOTO 106 IF(JE1.EQ.ITROU)THEN IENFAN=NTROV ELSE IENFAN=ABS(NCYCLE(2,JE1+1)) ENDIF IPSTAR=0 IPFIN=0 DO JE2=1,NCONNE(ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN) 1 IPFIN=CONNEC(1,JE2,ICOURA) IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN) 1 IPSTAR=CONNEC(1,JE2,ICOURA) ENDDO IF(IPSTAR*IPFIN.EQ.0)THEN IRAISO=11 SEGSUP,WORK GOTO 9999 ENDIF C C 8) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN) C WORK1=TWORK(ICOURA) NPTO1=WORK1.XYC(/2) NPTO2=IPFIN-IPSTAR IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1 NPTO=NPTO+NPTO2 SEGADJ,WORK IPCOUR=IPFIN DO JE2=1,NPTO2 IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1 XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR) XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR) DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR) ENDDO 106 CONTINUE C C 9) NOUVEAU CONTOUR DANS WORK2 C WORK2=WORK C C 10) ON AJUSTE LES TROUS (ON SUPRIME CEUX QUI ONT EFFECTIVEMENT C COALESCE C DO JE1=1,ITROU ICOURA=NCYCLE(2,JE1) IF(ICOURA.GT.0)THEN WORK=TWORK(ICOURA) IF(WORK.NE.0)THEN SEGSUP,WORK TWORK(ICOURA)=0 ENDIF ENDIF ENDDO C C COUPE: LA FACE "B" EST DANS WORK2 ET "A" DANS WWORK C C ON ORIENTE CORRECTEMENT B C ON CHERCHE LES CONNEXIONS C ON COUPE C ON NE S'OCCUPE QUE DE LA PARTIE EXTERIEURE A LA COUPE C 200 CONTINUE CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,WORK2.XYC(/2),1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=20 GOTO 9999 ENDIF WORK1=FWORK CALL J3COTO(WORK2,WORK1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=21 GOTO 9999 ENDIF CALL J3COTO(WORK1,WORK2,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=22 GOTO 9999 ENDIF CALL J3JUNC(WORK1,WORK2,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=23 GOTO 9999 ENDIF CALL J3JUNC(WORK2,WORK1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=24 GOTO 9999 ENDIF FWORK=WORK1 CALL J3COUP(WWORK,WORK2,VWDUMM,VWORK2,1,TOL,IRET) CALL J3DET1(VWDUMM) CALL J3HEAD(WWORK,VWORK2) C C ON AJOUTE LES NOUVELLES FACES ET ON FLINGUE l'ANCIENNE C NFACN=VWORK2.FWWORK(/1) IF(NFACN.EQ.0)THEN IRET=IRET+1 IRAISO=25 GOTO 9999 ENDIF WORK=FWORK SEGSUP,WWORK,WORK FWWORK(IE2)=VWORK2.FWWORK(NFACN) NFACE=NFACF+NFACN-1 SEGADJ,VWORK DO JE1=1,NFACN-1 FWWORK(NFACF+JE1)=VWORK2.FWWORK(JE1) ENDDO C C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2 C SEGSUP,WCYCL,VWORK2 IE2=IE2-1 NFACF=NFACE GOTO 1000 C C ON ENTRE DANS LE CAS DU CONTACT MULTI PONCTUEL ENTRE 2 TROUS JE1 ET JE2 C 300 CONTINUE WORK1=TWORK(JE1) WORK2=TWORK(JE2) C C ON VERIFIE... C CALL J3COTO(WORK2,WORK1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=30 GOTO 9999 ENDIF CALL J3COTO(WORK1,WORK2,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=31 GOTO 9999 ENDIF CALL J3JUNC(WORK1,WORK2,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=32 GOTO 9999 ENDIF CALL J3JUNC(WORK2,WORK1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=33 GOTO 9999 ENDIF C C ON COHALESCE DANS VWORK2 C CALL J3COAL(WORK1,WORK2,.FALSE.,VWORK2,NFACEA,TOL,IRET) IF(IRET.GT.0)THEN IRAISO=34 GOTO 9999 ELSE JUNC=WORK2.JUN IF(JUNC.NE.0)SEGSUP,JUNC SEGSUP,WORK2 TWORK(JE1)=WORK1 TWORK(JE2)=0 ENDIF C C ON DISTRIBUE C IF(NFACEA.GT.0)THEN CALL J3HEAD(WWORK,VWORK2) CALL J3COAK(WWORK,VWORK2,TOL,IRET) ENDIF C C ON AJUSTE C CALL J3REDU(WWORK) C C ON AJOUTE LES NOUVELLES FACES C NFACN=VWORK2.FWWORK(/1) IF(NFACN.EQ.0)THEN IRET=IRET+1 IRAISO=35 GOTO 9999 ENDIF NFACE=NFACF+NFACN SEGADJ,VWORK DO JE1=1,NFACN FWWORK(NFACF+JE1)=VWORK2.FWWORK(JE1) ENDDO C C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2 C SEGSUP,WCYCL,VWORK2 IE2=IE2-1 NFACF=NFACE GOTO 1000 C C C FIN BOUCLE FACE C 1001 CONTINUE C C FIN BOUCLE BLOCK C ENDDO C RETURN C C CONFIGURATION IMPOSSIBLE C 9999 CONTINUE IRET=IRET+1 SEGSUP,WCYCL WRITE(IOIMP,*)' J3SURE: CONFIGURATION IMPOSSIBLE NO.',IRAISO RETURN C END