C J3FAFA SOURCE CHAT 05/01/13 00:46:41 5004 SUBROUTINE J3FAFA(WWORK1,WWORK2,TOL,IRET,ICAS,VWORK1,VWORK2) C---------------------------------------------------- C TRAITEMENANT DU FACE A FACE (2D) C C VWORK1: NOUVELLES FACES DEJA TRAITEES C VWORK2: NOUVELLES FACES A TRAITEES C C CODE IST(1,I): 0 point non traite C 1 est sur le segment IST(2,I) C 2 est sur les segments IST(2,I) et IST(3,I) C -1 est a l'interieur C -2 est a l'exterieur C C CODE CRO(J,I): 1 cote sur le segment C -1 cote interieur C -2 cote exterieur C C PP 6/97 C Pierre Pegon/JRC Ispra C---------------------------------------------------- C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO 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,WWORK2.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 LOGICAL LAINB,LAOUB,LAONB,LACUB,LBINA,LBOUA,LBONA LOGICAL LCAINB,LCAOUB,LCAONB,LCBINA,LCBOUA,LCBONA LOGICAL LPLAN C IF (IIMPI.EQ.1789)THEN WRITE(IOIMP,*)'>>> On entre dans j3fafa <<<' ENDIF C VWORK1=0 VWORK2=0 IRET=0 C C ON REGARDE SI LES FACES SONT DANS LE MEME PLAN C SI OUI, ON ALIGNE LES POINTS C SI NON, ON SORT AVEC UN CAS 1 C CALL J3COPL(WWORK1,WWORK2,LPLAN,TOL) IF (.NOT.LPLAN)THEN ICAS=1 IF (IIMPI.EQ.1789)THEN WRITE(IOIMP,*)' >>> traitement de 2 faces non coplanaires <<<' ENDIF RETURN ENDIF IF (IIMPI.EQ.1789)THEN WRITE(IOIMP,*)' >>> face A <<<' CALL J3LIWW(WWORK1) WRITE(IOIMP,*)' >>> face B <<<' CALL J3LIWW(WWORK2) ENDIF C C ON COMMENCE PAR TRAITER LES CONTOURS EXTERIEURS C WORK1=WWORK1.FWORK WORK2=WWORK2.FWORK CALL J3COTO(WORK2,WORK1,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF CALL J3COTO(WORK1,WORK2,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF C C ON REGARDE SI 1 POINT DE A EST STRICTEMENT DANS B OU HORS DE B C OU SUR B C NPTO1=WORK1.XYC(/2) CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) C C ON REGARDE SI 1 POINT DE B EST STRICTEMENT DANS A OU HORS DE A C OU SUR A C NPTO2=WORK2.XYC(/2) CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA) C C ON S'OCCUPE TOUT D'ABORD DU CAS OU A ET B SONT COMPLETEMENT DISJOINTS C ==> ON ELIMINE LA SEULE POSSIBILITE DE CAS 3 STRICT ET UNE DE CAS 1 ET 2 C LACUB=.FALSE. IF(LAOUB.AND.(.NOT.LAONB))THEN IF(LAINB)THEN IRAISO=1 GOTO 9999 ENDIF IF(LBINA)THEN IF(LBOUA)THEN IRAISO=2 GOTO 9999 ENDIF GOTO 3 ELSE IF(.NOT.LBOUA)THEN IRAISO=3 GOTO 9999 ENDIF GOTO 1 ENDIF ENDIF C IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN IF((.NOT.LAINB).OR.(.NOT.LBOUA))THEN IRAISO=4 GOTO 9999 ENDIF GOTO 2 ENDIF C C POUR CONTINUER IL FAUT SAVOIR VRAIMENT SI ON COUPE C CALL J3JUNC(WORK1,WORK2,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF JUNC=WORK1.JUN CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB) LACUB=LCAINB.AND.LCAOUB C C ET SI ON RECOUPE! C CALL J3JUNC(WORK2,WORK1,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF JUNC=WORK2.JUN CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA) C C ON FINIT LE CAS 1 C IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)GOTO 1 C C ON FINIT LE CAS 2 C IF(.NOT.LCAOUB) GOTO 2 C C ON S'OCCUPE DU CAS 4 C IF(LACUB)GOTO 4 C C ON S'OCCUPE DU 4 "TANGENT" ET DU "FAUX" 3 C IF((.NOT.LCAINB).AND.(.NOT.LCBOUA).AND.LAONB)THEN IF(NAONB.EQ.1)THEN GOTO 3 ELSE GOTO 4 ENDIF ENDIF C IRAISO=5 GOTO 9999 C C CAS NO. 1: ON NE FAIT RIEN C 1 ICAS=1 C IF (IIMPI.EQ.1789)THEN WRITE(IOIMP,*)' >>> traitement d"un cas no.1 <<<' ENDIF C RETURN C C CAS NO. 2: ON CONTROLE LES TROUS C 2 ICAS=2 C IF (IIMPI.EQ.1789)THEN WRITE(IOIMP,*)' >>> traitement d"un cas no.2 <<<' ENDIF C NTROU1=WWORK1.TWORK(/1) NTROU2=WWORK2.TWORK(/1) IF(NTROU1.NE.0)THEN WRITE(IOIMP,*)'CAS 2: face A avec trrrou' IRAISO=21 GOTO 9999 ENDIF C C SI PAS DE TROU DANS B... ON VERIFIE SI A N'EST PAS EGAL A B C ET SI OUI ON LE REND IDENTIQUE C IF(NTROU2.EQ.0)THEN IF(NTROU1.EQ.0)THEN CALL J3IDEN(WORK1,WORK2,TOL) WWORK1.FWORK=WORK1 RETURN ELSE IRAISO=22 GOTO 9999 ENDIF C C ... SINON ON REMPLACE B PAR LES TROUS DE B C ELSE DO 20 IE1=1,NTROU2 WORK2=WWORK2.TWORK(IE1) CALL J3COTO(WORK2,WORK1,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF CALL J3COTO(WORK1,WORK2,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF C C 2 SEULS CAS A VERIFIER: CAS 1 DISJOINT (A SANS TROU) C CAS 2 C SINON ERREUR C NPTO1=WORK1.XYC(/2) CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) C NPTO2=WORK2.XYC(/2) CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA) C IF(LAOUB.AND.(.NOT.LAONB))THEN IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA).OR.(NTROU1.NE.0))THEN IRAISO=23 GOTO 9999 ENDIF GOTO 20 ENDIF C IF((.NOT.LAOUB).AND.(.NOT.LAONB))GOTO 20 C CALL J3JUNC(WORK1,WORK2,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF JUNC=WORK1.JUN CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB) LACUB=LCAINB.AND.LCAOUB IF(.NOT.LCAOUB) GOTO 20 IRAISO=24 GOTO 9999 20 CONTINUE ENDIF C RETURN C C CAS NO. 3: D'ABORD ON VERIFIE QUE B N'A PAS DE TROU C 3 ICAS=3 C IF (IIMPI.EQ.1789)THEN WRITE(IOIMP,*)' >>> traitement d"un cas no.3 <<<' ENDIF C NTROU2=WWORK2.TWORK(/1) IF(NTROU2.NE.0)THEN IRAISO=31 GOTO 9999 ENDIF C C ON CREE UNE NOUVELLE FACE (RECOPIE DE WORK2) C NFACE=1 SEGINI,VWORK1 SEGINI,WWORK=WWORK2 VWORK1.FWWORK(1)=WWORK SEGINI,WORK=WORK2 JUN=0 FWORK=WORK C C ON AJOUTE ENSUITE UN TROU A A QUE L'ON MET EN PREMIERE C POSITION (ON INVERSE LA NUMEROTATION DE B) C NTROU1=WWORK1.TWORK(/1)+1 NTROU=NTROU1 SEGADJ,WWORK1 IF (NTROU1.GT.1)THEN DO IE1=NTROU1,2,-1 WWORK1.TWORK(IE1)=WWORK1.TWORK(IE1-1) ENDDO ENDIF C SEGINI,WORK1=WORK2 WORK1.JUN=0 NPTO1=NPTO2 CALL J3ORIE(1,WORK1.XYC,WORK1.DENS,NPTO1,-1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=32 GOTO 9999 ENDIF WWORK1.TWORK(1)=WORK1 C C SI UN SEUL TROU ON SORT C IF(NTROU1.EQ.1)RETURN C C ON VERIFIE QUE CE NOUVEAU TROU EST UN CAS 1 VIS A VIS DES C AUTRES TROUS DE A (ATTENTION, ON COMPTE LE NB DE CAS AVEC C CONTACT EN 1 SEUL POINT) C DO 30 IE1=2,NTROU1 WORK2=WWORK1.TWORK(IE1) IF(WORK2.EQ.0)GOTO 30 CALL J3COTO(WORK2,WORK1,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF CALL J3COTO(WORK1,WORK2,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF C NPTO1=WORK1.XYC(/2) CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) C NPTO2=WORK2.XYC(/2) CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA) C C A-T-ON UN CAS 1 DISJOINT? (SI OUI ON PASSE AU TROU SUIVANT) C IF(LAOUB.AND.(.NOT.LAONB))THEN IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA))THEN IRAISO=33 GOTO 9999 ENDIF GOTO 30 ENDIF C C A-T-ON UN CAS 1 AVEC CONTACT ? (SI OUI ON COALESCE) C (ATTENTION, ON EXCLUT LE CONTACT PONCTUEL EN 1 SEUL POINT)) C WARNING UN CAS 2 SEMBLE LICITE!!!!!!!! C IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN IF((.NOT.LAINB).OR.(.NOT.LBOUA))THEN IRAISO=34 GOTO 9999 ENDIF SEGSUP,WORK,WWORK,VWORK1,WORK1 WWORK1.TWORK(1)=0 ICAS=1 GOTO 31 ENDIF C CALL J3JUNC(WORK1,WORK2,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF JUNC=WORK1.JUN NPTO1=WORK1.XYC(/2) CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB) LACUB=LCAINB.AND.LCAOUB C CALL J3JUNC(WORK2,WORK1,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF NPTO2=WORK2.XYC(/2) JUNC=WORK2.JUN CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA) C IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)THEN IF(NAONB.EQ.1)GOTO 30 CALL J3COAL(WORK1,WORK2,LCAONB,VWORK,NFACEA,TOL,IRET) IF(IRET.GT.0)THEN RETURN ELSE JUNC=WORK2.JUN IF(JUNC.NE.0)SEGSUP,JUNC SEGSUP,WORK2 WWORK1.TWORK(1)=WORK1 WWORK1.TWORK(IE1)=0 ENDIF C C ATTENTION UNE DES NFACEA FACES EVENTUELLEMENT CREES PEUT C CONTENIR STRICTEMENT UN DES TROU DE A QUI DEVIENT UN TROU DE LA C NOUVELLE FACE C IF(NFACEA.GT.0)THEN CALL J3HEAD(WWORK1,VWORK) CALL J3COAK(WWORK1,VWORK,TOL,IRET) CALL J3VPLU(VWORK2,VWORK) ENDIF ELSE C C ON EJECTE UN CAS 2 AVEC CONTACT QUI EST LICITE C IF (.NOT.LCAOUB)THEN SEGSUP,WORK,WWORK,VWORK1,WORK1 WWORK1.TWORK(1)=0 ICAS=1 GOTO 31 ENDIF IRAISO=35 GOTO 9999 ENDIF 30 CONTINUE C C ON REDUIT LE TWORK DE A DU NOMBRE DE COALESCENCE C 31 CALL J3REDU(WWORK1) C C RETURN C C CAS NO. 4: ON CONTROLE LES TROU DE B C 4 ICAS=4 C IF (IIMPI.EQ.1789)THEN WRITE(IOIMP,*)' >>> traitement d"un cas no.4 <<<' ENDIF C NTROU2=WWORK2.TWORK(/1) IF(NTROU2.NE.0)THEN IRAISO=41 GOTO 9999 ENDIF C C ON COUPE A PAR B ET ON GARDE LA PARTIE INTERIEURE (SANS C REDISTRIBUTION DES TROU) DANS VWORK1. C CALL J3COUP(WWORK1,WORK2,VWORK1,VWORK,0,TOL,IRET) IF (IRET.GT.0)THEN IRAISO=42 GOTO 9999 ENDIF CALL J3HEAD(WWORK1,VWORK1) C C S'IL N'Y A PAS DE TROU DANS A ON SAUTE DIRECTEMENT C APRES LA PHASE DE SECONDE COUPE C NTROU1=WWORK1.TWORK(/1) IF(NTROU1.EQ.0)GOTO 45 CALL J3DET1(VWORK) C C S'IL Y A DES TROU DANS A, ILS DOIVENT ETRE DES CAS 1 VIS A VIS C DE B ET EVENTUELLEMENT COHALESCER AVEC B ET DONC ON COMMENCE PAR C INVERSER B DANS WORK1, ENSUITE ON CONTINUE COMME DANS CAS 3 C SEGINI,WORK1=WORK2 WORK1.JUN=0 NPTO1=NPTO2 CALL J3ORIE(1,WORK1.XYC,WORK1.DENS,NPTO1,-1,TOL,IRET) IF(IRET.NE.0)THEN RETURN ENDIF C C WARNING: ON PROCEDE "B PAR RAPPORT A A" POUR FINIR AVEC LE MEME NB DE C POINTS EN CAS DE COALESCENCE" C DO 40 IE1=1,NTROU1 WORK2=WWORK1.TWORK(IE1) IF(WORK2.EQ.0)GOTO 40 CALL J3COTO(WORK2,WORK1,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF CALL J3COTO(WORK1,WORK2,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF C NPTO1=WORK1.XYC(/2) CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) C NPTO2=WORK2.XYC(/2) CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA) C C A-T-ON UN CAS 1 DISJOINT? (SI OUI ON PASSE AU TROU SUIVANT) C IF(LAOUB.AND.(.NOT.LAONB))THEN IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA))THEN IRAISO=43 GOTO 9999 ENDIF GOTO 40 ENDIF C C A-T-ON UN CAS 1 AVEC CONTACT? (SI OUI ON COALESCE) C (ATTENTION, ON EXCLUT LE CONTACT PONCTUEL EN 1 SEUL POINT) C IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN IRAISO=43 GOTO 9999 ENDIF C CALL J3JUNC(WORK1,WORK2,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF JUNC=WORK1.JUN NPTO1=WORK1.XYC(/2) CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB) LACUB=LCAINB.AND.LCAOUB C CALL J3JUNC(WORK2,WORK1,TOL,IRET) IF (IRET.GT.0)THEN RETURN ENDIF NPTO2=WORK2.XYC(/2) JUNC=WORK2.JUN CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA) C IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)THEN IF(NAONB.EQ.1)GOTO 40 CALL J3JUNC(WORK2,WORK1,TOL,IRET) CALL J3COAL(WORK1,WORK2,LCAONB,VWORK,NFACEA,TOL,IRET) IF(IRET.GT.0)THEN RETURN ELSE JUNC=WORK2.JUN IF(JUNC.NE.0)SEGSUP,JUNC SEGSUP,WORK2 WWORK1.TWORK(IE1)=0 ENDIF C ATTENTION UNE DES NFACEA FACES EVENTUELLEMENT CREES PEUT C CONTENIR STRICTEMENT UN DES TROU DE A QUI DEVIENT UN TROU DE LA C NOUVELLE FACE C IF(NFACEA.GT.0)THEN CALL J3HEAD(WWORK1,VWORK) CALL J3COAK(WWORK1,VWORK,TOL,IRET) CALL J3VPLU(VWORK2,VWORK) ENDIF ELSE IRAISO=44 GOTO 9999 ENDIF 40 CONTINUE C C ON REDUIT LE TWORK DE A DU NOMBRE DE COALESCENCE C CALL J3REDU(WWORK1) C C ON INVERSE MAINTENANT LA NUMEROTATION DE WORK1 DANS WORK2 C WORK2=WORK1 NPTO2=WORK2.XYC(/2) CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,NPTO2,1,TOL,IRET) C PP? CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,NPTO2,-1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=45 GOTO 9999 ENDIF C C ON REMET A DANS WORK1 ET ON REFAIT LES TESTS C WORK1=WWORK1.FWORK CALL J3COTO(WORK2,WORK1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=46 GOTO 9999 ENDIF CALL J3COTO(WORK1,WORK2,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=47 GOTO 9999 ENDIF CALL J3JUNC(WORK1,WORK2,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=48 GOTO 9999 ENDIF C C C'EST ICI QUE L'ON RE-COUPE (A EST DANS WORK1 ET B COHALESCE C DANS WORK2) C C ON REGARDE D'ABORD EGALEMENT COMMENT B COUPE A C CALL J3JUNC(WORK2,WORK1,TOL,IRET) IF(IRET.NE.0)THEN IRAISO=49 GOTO 9999 ENDIF C C PUIS ON COUPE (ON NE S'INTERESSE QUE A LA PARTIE C EXTERIEURE VWORK) C WWORK1.FWORK=WORK1 CALL J3COUP(WWORK1,WORK2,VWDUMM,VWORK,1,TOL,IRET) CALL J3DET1(VWDUMM) C 45 CALL J3HEAD(WWORK1,VWORK) CALL J3VPLU(VWORK2,VWORK) C RETURN C C CONFIGURATION IMPOSSIBLE C 9999 CONTINUE WRITE(IOIMP,*)' J3FAFA: CONFIGURATION IMPOSSIBLE NO.',IRAISO IRET=IRET+1 RETURN C END