Télécharger la plaquette Cast3M


fr en

Télécharger j3coal.eso

Retour à la liste

Numérotation des lignes : 

j3coal

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

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