Télécharger la plaquette Cast3M


fr en

Télécharger j3fafa.eso

Retour à la liste

Numérotation des lignes : 

j3fafa

  1. C J3FAFA    SOURCE    CHAT      05/01/13    00:46:41     5004
  2.       SUBROUTINE J3FAFA(WWORK1,WWORK2,TOL,IRET,ICAS,VWORK1,VWORK2)
  3. C----------------------------------------------------
  4. C     TRAITEMENANT DU FACE A FACE (2D)
  5. C
  6. C     VWORK1: NOUVELLES FACES DEJA TRAITEES
  7. C     VWORK2: NOUVELLES FACES A TRAITEES
  8. C
  9. C     CODE IST(1,I): 0 point non traite
  10. C                    1 est sur le segment IST(2,I)
  11. C                    2 est sur les segments IST(2,I) et IST(3,I)
  12. C                   -1 est a l'interieur
  13. C                   -2 est a l'exterieur
  14. C
  15. C     CODE CRO(J,I): 1 cote sur le segment
  16. C                   -1 cote interieur
  17. C                   -2 cote exterieur
  18. C
  19. C     PP 6/97
  20. C     Pierre Pegon/JRC Ispra
  21. C----------------------------------------------------
  22. C
  23.       IMPLICIT INTEGER(I-N)
  24.       IMPLICIT REAL*8(A-H,O-Z)
  25. -INC PPARAM
  26. -INC CCOPTIO
  27.       SEGMENT VWORK
  28.         INTEGER FWWORK(NFACE)
  29.       ENDSEGMENT
  30.       POINTEUR VWORK1.VWORK,VWORK2.VWORK,VWDUMM.VWORK
  31. C
  32.       SEGMENT WWORK
  33.         REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  34.         INTEGER FWORK
  35.         INTEGER TWORK(NTROU)
  36.       ENDSEGMENT
  37.       POINTEUR WWORK1.WWORK,WWORK2.WWORK
  38. C
  39.       SEGMENT WORK
  40.         REAL*8 XYC(2,NPTO)
  41.         INTEGER IST(3,NPTO)
  42.         REAL*8 DENS(NPTO)
  43.         INTEGER JUN
  44.       ENDSEGMENT
  45.       POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK
  46. C
  47.       SEGMENT JUNC
  48.         INTEGER CRO(2,NPTO)
  49.       ENDSEGMENT
  50. C
  51.       LOGICAL LAINB,LAOUB,LAONB,LACUB,LBINA,LBOUA,LBONA
  52.       LOGICAL LCAINB,LCAOUB,LCAONB,LCBINA,LCBOUA,LCBONA
  53.       LOGICAL LPLAN
  54. C
  55.       IF (IIMPI.EQ.1789)THEN
  56.         WRITE(IOIMP,*)'>>> On entre dans j3fafa <<<'
  57.       ENDIF
  58. C
  59.       VWORK1=0
  60.       VWORK2=0
  61.       IRET=0
  62. C
  63. C     ON REGARDE SI LES FACES SONT DANS LE MEME PLAN
  64. C       SI OUI, ON ALIGNE LES POINTS
  65. C       SI NON, ON SORT AVEC UN CAS 1
  66. C
  67.       CALL J3COPL(WWORK1,WWORK2,LPLAN,TOL)
  68.       IF (.NOT.LPLAN)THEN
  69.         ICAS=1
  70.         IF (IIMPI.EQ.1789)THEN
  71.           WRITE(IOIMP,*)' >>> traitement de 2 faces non coplanaires <<<'
  72.         ENDIF
  73.         RETURN
  74.       ENDIF
  75.       IF (IIMPI.EQ.1789)THEN
  76.           WRITE(IOIMP,*)' >>> face A <<<'
  77.           CALL J3LIWW(WWORK1)
  78.           WRITE(IOIMP,*)' >>> face B <<<'
  79.           CALL J3LIWW(WWORK2)
  80.       ENDIF
  81. C
  82. C     ON COMMENCE PAR TRAITER LES CONTOURS EXTERIEURS
  83. C
  84.       WORK1=WWORK1.FWORK
  85.       WORK2=WWORK2.FWORK
  86.       CALL J3COTO(WORK2,WORK1,TOL,IRET)
  87.       IF (IRET.GT.0)THEN
  88.         RETURN
  89.       ENDIF
  90.       CALL J3COTO(WORK1,WORK2,TOL,IRET)
  91.       IF (IRET.GT.0)THEN
  92.         RETURN
  93.       ENDIF
  94. C
  95. C     ON REGARDE SI 1 POINT DE A EST STRICTEMENT DANS B OU HORS DE B
  96. C        OU SUR B
  97. C
  98.       NPTO1=WORK1.XYC(/2)
  99.       CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  100. C
  101. C     ON REGARDE SI 1 POINT DE B EST STRICTEMENT DANS A OU HORS DE A
  102. C        OU SUR A
  103. C
  104.       NPTO2=WORK2.XYC(/2)
  105.       CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  106. C
  107. C     ON S'OCCUPE TOUT D'ABORD DU CAS OU A ET B SONT COMPLETEMENT DISJOINTS
  108. C     ==> ON ELIMINE LA SEULE POSSIBILITE DE CAS 3 STRICT ET UNE DE CAS 1 ET 2
  109. C
  110.       LACUB=.FALSE.
  111.       IF(LAOUB.AND.(.NOT.LAONB))THEN
  112.         IF(LAINB)THEN
  113.           IRAISO=1
  114.           GOTO 9999
  115.         ENDIF
  116.         IF(LBINA)THEN
  117.           IF(LBOUA)THEN
  118.             IRAISO=2
  119.             GOTO 9999
  120.           ENDIF
  121.           GOTO 3
  122.         ELSE
  123.           IF(.NOT.LBOUA)THEN
  124.             IRAISO=3
  125.             GOTO 9999
  126.           ENDIF
  127.           GOTO 1
  128.         ENDIF
  129.       ENDIF
  130. C
  131.       IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN
  132.         IF((.NOT.LAINB).OR.(.NOT.LBOUA))THEN
  133.           IRAISO=4
  134.           GOTO 9999
  135.         ENDIF
  136.         GOTO 2
  137.       ENDIF
  138. C
  139. C     POUR CONTINUER IL FAUT SAVOIR VRAIMENT SI ON COUPE
  140. C
  141.       CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  142.       IF (IRET.GT.0)THEN
  143.         RETURN
  144.       ENDIF
  145.       JUNC=WORK1.JUN
  146.       CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB)
  147.       LACUB=LCAINB.AND.LCAOUB
  148. C
  149. C     ET SI ON RECOUPE!
  150. C
  151.       CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  152.       IF (IRET.GT.0)THEN
  153.         RETURN
  154.       ENDIF
  155.       JUNC=WORK2.JUN
  156.       CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA)
  157. C
  158. C     ON FINIT LE CAS 1
  159. C
  160.       IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)GOTO 1
  161. C
  162. C     ON FINIT LE CAS 2
  163. C
  164.       IF(.NOT.LCAOUB) GOTO 2
  165. C
  166. C     ON S'OCCUPE DU CAS 4
  167. C
  168.       IF(LACUB)GOTO 4
  169. C
  170. C     ON S'OCCUPE DU 4 "TANGENT" ET DU "FAUX" 3
  171. C
  172.       IF((.NOT.LCAINB).AND.(.NOT.LCBOUA).AND.LAONB)THEN
  173.         IF(NAONB.EQ.1)THEN
  174.           GOTO 3
  175.         ELSE
  176.           GOTO 4
  177.         ENDIF
  178.       ENDIF
  179. C
  180.  
  181.       IRAISO=5
  182.       GOTO 9999
  183. C
  184. C     CAS NO. 1: ON NE FAIT RIEN
  185. C
  186.  1    ICAS=1
  187. C
  188.       IF (IIMPI.EQ.1789)THEN
  189.         WRITE(IOIMP,*)'    >>> traitement d"un cas no.1 <<<'
  190.       ENDIF
  191. C
  192.       RETURN
  193. C
  194. C     CAS NO. 2: ON CONTROLE LES TROUS
  195. C
  196.  2    ICAS=2
  197. C
  198.       IF (IIMPI.EQ.1789)THEN
  199.         WRITE(IOIMP,*)'    >>> traitement d"un cas no.2 <<<'
  200.       ENDIF
  201. C
  202.       NTROU1=WWORK1.TWORK(/1)
  203.       NTROU2=WWORK2.TWORK(/1)
  204.       IF(NTROU1.NE.0)THEN
  205.         WRITE(IOIMP,*)'CAS 2: face A avec trrrou'
  206.         IRAISO=21
  207.         GOTO 9999
  208.       ENDIF
  209. C
  210. C      SI PAS DE TROU DANS B... ON VERIFIE SI A N'EST PAS EGAL A B
  211. C      ET SI OUI ON LE REND IDENTIQUE
  212. C
  213.       IF(NTROU2.EQ.0)THEN
  214.         IF(NTROU1.EQ.0)THEN
  215.           CALL J3IDEN(WORK1,WORK2,TOL)
  216.           WWORK1.FWORK=WORK1
  217.           RETURN
  218.         ELSE
  219.           IRAISO=22
  220.           GOTO 9999
  221.         ENDIF
  222. C
  223. C      ... SINON ON REMPLACE B PAR LES TROUS DE B
  224. C
  225.       ELSE
  226.         DO 20 IE1=1,NTROU2
  227.           WORK2=WWORK2.TWORK(IE1)
  228.           CALL J3COTO(WORK2,WORK1,TOL,IRET)
  229.           IF (IRET.GT.0)THEN
  230.             RETURN
  231.           ENDIF
  232.           CALL J3COTO(WORK1,WORK2,TOL,IRET)
  233.           IF (IRET.GT.0)THEN
  234.             RETURN
  235.           ENDIF
  236. C
  237. C       2 SEULS CAS A VERIFIER: CAS 1 DISJOINT (A SANS TROU)
  238. C                               CAS 2
  239. C         SINON ERREUR
  240. C
  241.           NPTO1=WORK1.XYC(/2)
  242.           CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  243. C
  244.           NPTO2=WORK2.XYC(/2)
  245.           CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  246. C
  247.           IF(LAOUB.AND.(.NOT.LAONB))THEN
  248.             IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA).OR.(NTROU1.NE.0))THEN
  249.               IRAISO=23
  250.               GOTO 9999
  251.             ENDIF
  252.             GOTO 20
  253.           ENDIF
  254. C
  255.           IF((.NOT.LAOUB).AND.(.NOT.LAONB))GOTO 20
  256. C
  257.           CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  258.           IF (IRET.GT.0)THEN
  259.             RETURN
  260.           ENDIF
  261.           JUNC=WORK1.JUN
  262.           CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB)
  263.           LACUB=LCAINB.AND.LCAOUB
  264.           IF(.NOT.LCAOUB) GOTO 20
  265.           IRAISO=24
  266.           GOTO 9999
  267.  20     CONTINUE
  268.       ENDIF
  269. C
  270.       RETURN
  271. C
  272. C     CAS NO. 3: D'ABORD ON VERIFIE QUE B N'A PAS DE TROU
  273. C
  274.  3    ICAS=3
  275. C
  276.       IF (IIMPI.EQ.1789)THEN
  277.         WRITE(IOIMP,*)'    >>> traitement d"un cas no.3 <<<'
  278.       ENDIF
  279. C
  280.       NTROU2=WWORK2.TWORK(/1)
  281.       IF(NTROU2.NE.0)THEN
  282.         IRAISO=31
  283.         GOTO 9999
  284.       ENDIF
  285. C
  286. C       ON CREE UNE NOUVELLE FACE (RECOPIE DE WORK2)
  287. C
  288.       NFACE=1
  289.       SEGINI,VWORK1
  290.       SEGINI,WWORK=WWORK2
  291.       VWORK1.FWWORK(1)=WWORK
  292.       SEGINI,WORK=WORK2
  293.       JUN=0
  294.       FWORK=WORK
  295. C
  296. C       ON AJOUTE ENSUITE UN TROU A A QUE L'ON MET EN PREMIERE
  297. C       POSITION (ON INVERSE LA NUMEROTATION DE B)
  298. C
  299.       NTROU1=WWORK1.TWORK(/1)+1
  300.       NTROU=NTROU1
  301.       SEGADJ,WWORK1
  302.       IF (NTROU1.GT.1)THEN
  303.         DO IE1=NTROU1,2,-1
  304.           WWORK1.TWORK(IE1)=WWORK1.TWORK(IE1-1)
  305.         ENDDO
  306.       ENDIF
  307. C
  308.       SEGINI,WORK1=WORK2
  309.       WORK1.JUN=0
  310.       NPTO1=NPTO2
  311.       CALL J3ORIE(1,WORK1.XYC,WORK1.DENS,NPTO1,-1,TOL,IRET)
  312.       IF(IRET.NE.0)THEN
  313.         IRAISO=32
  314.         GOTO 9999
  315.       ENDIF
  316.       WWORK1.TWORK(1)=WORK1
  317. C
  318. C       SI UN SEUL TROU ON SORT
  319. C
  320.       IF(NTROU1.EQ.1)RETURN
  321. C
  322. C       ON VERIFIE QUE CE NOUVEAU TROU EST UN CAS 1 VIS A VIS DES
  323. C       AUTRES TROUS DE A (ATTENTION, ON COMPTE LE NB DE CAS AVEC
  324. C                          CONTACT EN 1 SEUL POINT)
  325. C
  326.       DO 30 IE1=2,NTROU1
  327.         WORK2=WWORK1.TWORK(IE1)
  328.         IF(WORK2.EQ.0)GOTO 30
  329.         CALL J3COTO(WORK2,WORK1,TOL,IRET)
  330.         IF (IRET.GT.0)THEN
  331.           RETURN
  332.         ENDIF
  333.         CALL J3COTO(WORK1,WORK2,TOL,IRET)
  334.         IF (IRET.GT.0)THEN
  335.           RETURN
  336.         ENDIF
  337. C
  338.         NPTO1=WORK1.XYC(/2)
  339.         CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  340. C
  341.         NPTO2=WORK2.XYC(/2)
  342.         CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  343. C
  344. C       A-T-ON UN CAS 1 DISJOINT? (SI OUI ON PASSE AU TROU SUIVANT)
  345. C
  346.         IF(LAOUB.AND.(.NOT.LAONB))THEN
  347.           IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA))THEN
  348.             IRAISO=33
  349.             GOTO 9999
  350.           ENDIF
  351.           GOTO 30
  352.         ENDIF
  353. C
  354. C       A-T-ON UN CAS 1 AVEC CONTACT ? (SI OUI ON COALESCE)
  355. C       (ATTENTION, ON EXCLUT LE CONTACT PONCTUEL EN 1 SEUL POINT))
  356. C       WARNING UN CAS 2 SEMBLE LICITE!!!!!!!!
  357. C
  358.         IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN
  359.           IF((.NOT.LAINB).OR.(.NOT.LBOUA))THEN
  360.             IRAISO=34
  361.             GOTO 9999
  362.           ENDIF
  363.           SEGSUP,WORK,WWORK,VWORK1,WORK1
  364.           WWORK1.TWORK(1)=0
  365.           ICAS=1
  366.           GOTO 31
  367.         ENDIF
  368. C
  369.         CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  370.         IF (IRET.GT.0)THEN
  371.           RETURN
  372.         ENDIF
  373.         JUNC=WORK1.JUN
  374.         NPTO1=WORK1.XYC(/2)
  375.         CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB)
  376.         LACUB=LCAINB.AND.LCAOUB
  377. C
  378.         CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  379.         IF (IRET.GT.0)THEN
  380.           RETURN
  381.         ENDIF
  382.         NPTO2=WORK2.XYC(/2)
  383.         JUNC=WORK2.JUN
  384.         CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA)
  385. C
  386.         IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)THEN
  387.           IF(NAONB.EQ.1)GOTO 30
  388.           CALL J3COAL(WORK1,WORK2,LCAONB,VWORK,NFACEA,TOL,IRET)
  389.           IF(IRET.GT.0)THEN
  390.             RETURN
  391.           ELSE
  392.             JUNC=WORK2.JUN
  393.             IF(JUNC.NE.0)SEGSUP,JUNC
  394.             SEGSUP,WORK2
  395.             WWORK1.TWORK(1)=WORK1
  396.             WWORK1.TWORK(IE1)=0
  397.           ENDIF
  398. C
  399. C       ATTENTION UNE DES NFACEA FACES EVENTUELLEMENT CREES PEUT
  400. C       CONTENIR STRICTEMENT UN DES TROU DE A QUI DEVIENT UN TROU DE LA
  401. C       NOUVELLE FACE
  402. C
  403.           IF(NFACEA.GT.0)THEN
  404.             CALL J3HEAD(WWORK1,VWORK)
  405.             CALL J3COAK(WWORK1,VWORK,TOL,IRET)
  406.             CALL J3VPLU(VWORK2,VWORK)
  407.           ENDIF
  408.         ELSE
  409. C
  410. C       ON EJECTE UN CAS 2 AVEC CONTACT QUI EST LICITE
  411. C
  412.           IF (.NOT.LCAOUB)THEN
  413.             SEGSUP,WORK,WWORK,VWORK1,WORK1
  414.             WWORK1.TWORK(1)=0
  415.             ICAS=1
  416.             GOTO 31
  417.           ENDIF
  418.           IRAISO=35
  419.           GOTO 9999
  420.         ENDIF
  421.  30   CONTINUE
  422. C
  423. C       ON REDUIT LE TWORK DE A DU NOMBRE DE COALESCENCE
  424. C
  425.  31   CALL J3REDU(WWORK1)
  426. C
  427. C
  428.       RETURN
  429. C
  430. C     CAS NO. 4: ON CONTROLE LES TROU DE B
  431. C
  432.  4    ICAS=4
  433. C
  434.       IF (IIMPI.EQ.1789)THEN
  435.         WRITE(IOIMP,*)'    >>> traitement d"un cas no.4 <<<'
  436.       ENDIF
  437. C
  438.       NTROU2=WWORK2.TWORK(/1)
  439.       IF(NTROU2.NE.0)THEN
  440.         IRAISO=41
  441.         GOTO 9999
  442.       ENDIF
  443. C
  444. C     ON COUPE A PAR B ET ON GARDE LA PARTIE INTERIEURE (SANS
  445. C     REDISTRIBUTION DES TROU) DANS VWORK1.
  446. C
  447.       CALL J3COUP(WWORK1,WORK2,VWORK1,VWORK,0,TOL,IRET)
  448.       IF (IRET.GT.0)THEN
  449.         IRAISO=42
  450.         GOTO 9999
  451.       ENDIF
  452.       CALL J3HEAD(WWORK1,VWORK1)
  453. C
  454. C     S'IL N'Y A PAS DE TROU DANS A ON SAUTE DIRECTEMENT
  455. C     APRES LA PHASE DE SECONDE COUPE
  456. C
  457.       NTROU1=WWORK1.TWORK(/1)
  458.       IF(NTROU1.EQ.0)GOTO 45
  459.       CALL J3DET1(VWORK)
  460. C
  461. C     S'IL Y A DES TROU DANS A, ILS DOIVENT ETRE DES CAS 1 VIS A VIS
  462. C     DE B ET EVENTUELLEMENT COHALESCER AVEC B ET DONC ON COMMENCE PAR
  463. C     INVERSER B DANS WORK1, ENSUITE ON CONTINUE COMME DANS CAS 3
  464. C
  465.       SEGINI,WORK1=WORK2
  466.       WORK1.JUN=0
  467.       NPTO1=NPTO2
  468.       CALL J3ORIE(1,WORK1.XYC,WORK1.DENS,NPTO1,-1,TOL,IRET)
  469.       IF(IRET.NE.0)THEN
  470.         RETURN
  471.       ENDIF
  472. C
  473. C     WARNING: ON PROCEDE "B PAR RAPPORT A A" POUR FINIR AVEC LE MEME NB DE
  474. C       POINTS EN CAS DE COALESCENCE"
  475. C
  476.       DO 40 IE1=1,NTROU1
  477.         WORK2=WWORK1.TWORK(IE1)
  478.         IF(WORK2.EQ.0)GOTO 40
  479.         CALL J3COTO(WORK2,WORK1,TOL,IRET)
  480.         IF (IRET.GT.0)THEN
  481.           RETURN
  482.         ENDIF
  483.         CALL J3COTO(WORK1,WORK2,TOL,IRET)
  484.         IF (IRET.GT.0)THEN
  485.           RETURN
  486.         ENDIF
  487. C
  488.         NPTO1=WORK1.XYC(/2)
  489.         CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  490. C
  491.         NPTO2=WORK2.XYC(/2)
  492.         CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  493. C
  494. C       A-T-ON UN CAS 1 DISJOINT? (SI OUI ON PASSE AU TROU SUIVANT)
  495. C
  496.         IF(LAOUB.AND.(.NOT.LAONB))THEN
  497.           IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA))THEN
  498.             IRAISO=43
  499.             GOTO 9999
  500.           ENDIF
  501.           GOTO 40
  502.         ENDIF
  503. C
  504. C       A-T-ON UN CAS 1 AVEC CONTACT? (SI OUI ON COALESCE)
  505. C       (ATTENTION, ON EXCLUT LE CONTACT PONCTUEL EN 1 SEUL POINT)
  506. C
  507.         IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN
  508.           IRAISO=43
  509.           GOTO 9999
  510.         ENDIF
  511. C
  512.         CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  513.         IF (IRET.GT.0)THEN
  514.           RETURN
  515.         ENDIF
  516.         JUNC=WORK1.JUN
  517.         NPTO1=WORK1.XYC(/2)
  518.         CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB)
  519.         LACUB=LCAINB.AND.LCAOUB
  520. C
  521.         CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  522.         IF (IRET.GT.0)THEN
  523.           RETURN
  524.         ENDIF
  525.         NPTO2=WORK2.XYC(/2)
  526.         JUNC=WORK2.JUN
  527.         CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA)
  528. C
  529.         IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)THEN
  530.           IF(NAONB.EQ.1)GOTO 40
  531.           CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  532.           CALL J3COAL(WORK1,WORK2,LCAONB,VWORK,NFACEA,TOL,IRET)
  533.           IF(IRET.GT.0)THEN
  534.             RETURN
  535.           ELSE
  536.             JUNC=WORK2.JUN
  537.             IF(JUNC.NE.0)SEGSUP,JUNC
  538.             SEGSUP,WORK2
  539.             WWORK1.TWORK(IE1)=0
  540.           ENDIF
  541.  
  542. C       ATTENTION UNE DES NFACEA FACES EVENTUELLEMENT CREES PEUT
  543. C       CONTENIR STRICTEMENT UN DES TROU DE A QUI DEVIENT UN TROU DE LA
  544. C       NOUVELLE FACE
  545. C
  546.           IF(NFACEA.GT.0)THEN
  547.             CALL J3HEAD(WWORK1,VWORK)
  548.             CALL J3COAK(WWORK1,VWORK,TOL,IRET)
  549.             CALL J3VPLU(VWORK2,VWORK)
  550.           ENDIF
  551.         ELSE
  552.           IRAISO=44
  553.           GOTO 9999
  554.         ENDIF
  555.  40   CONTINUE
  556. C
  557. C       ON REDUIT LE TWORK DE A DU NOMBRE DE COALESCENCE
  558. C
  559.       CALL J3REDU(WWORK1)
  560. C
  561. C     ON INVERSE MAINTENANT LA NUMEROTATION DE WORK1 DANS WORK2
  562. C
  563.       WORK2=WORK1
  564.       NPTO2=WORK2.XYC(/2)
  565.       CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,NPTO2,1,TOL,IRET)
  566. C PP?  CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,NPTO2,-1,TOL,IRET)
  567.       IF(IRET.NE.0)THEN
  568.         IRAISO=45
  569.         GOTO 9999
  570.       ENDIF
  571. C
  572. C     ON REMET A DANS WORK1 ET ON REFAIT LES TESTS
  573. C
  574.       WORK1=WWORK1.FWORK
  575.       CALL J3COTO(WORK2,WORK1,TOL,IRET)
  576.       IF(IRET.NE.0)THEN
  577.         IRAISO=46
  578.         GOTO 9999
  579.       ENDIF
  580.       CALL J3COTO(WORK1,WORK2,TOL,IRET)
  581.       IF(IRET.NE.0)THEN
  582.         IRAISO=47
  583.         GOTO 9999
  584.       ENDIF
  585.       CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  586.       IF(IRET.NE.0)THEN
  587.         IRAISO=48
  588.         GOTO 9999
  589.       ENDIF
  590. C
  591. C     C'EST ICI QUE L'ON RE-COUPE (A EST DANS WORK1 ET B COHALESCE
  592. C     DANS WORK2)
  593. C
  594. C     ON REGARDE D'ABORD EGALEMENT COMMENT B COUPE A
  595. C
  596.       CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  597.       IF(IRET.NE.0)THEN
  598.         IRAISO=49
  599.         GOTO 9999
  600.       ENDIF
  601. C
  602. C     PUIS ON COUPE (ON NE S'INTERESSE QUE A LA PARTIE
  603. C     EXTERIEURE VWORK)
  604. C
  605.       WWORK1.FWORK=WORK1
  606.       CALL J3COUP(WWORK1,WORK2,VWDUMM,VWORK,1,TOL,IRET)
  607.       CALL J3DET1(VWDUMM)
  608. C
  609.  45   CALL J3HEAD(WWORK1,VWORK)
  610.       CALL J3VPLU(VWORK2,VWORK)
  611. C
  612.       RETURN
  613. C
  614. C     CONFIGURATION IMPOSSIBLE
  615. C
  616.  9999 CONTINUE
  617.       WRITE(IOIMP,*)' J3FAFA: CONFIGURATION IMPOSSIBLE NO.',IRAISO
  618.       IRET=IRET+1
  619.       RETURN
  620. C
  621.       END
  622.  
  623.  
  624.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales