Télécharger la plaquette Cast3M


fr en

Télécharger coupe.eso

Retour à la liste

Numérotation des lignes : 

coupe

  1. C COUPE     SOURCE    FD218221  23/08/04    21:15:05     11719          
  2.       SUBROUTINE COUPE
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC SMELEME
  9. -INC CCGEOME
  10. -INC SMCOORD
  11. -INC SMLENTI
  12. -INC SMLREEL
  13. C
  14.       DIMENSION XYZT(3),XYZ2(3),XYZ3(3),XYZN(3)
  15.       DIMENSION XYZ(4,4),DIS(4)
  16. C
  17.       EQUIVALENCE(XYZT(1),XCT),(XYZT(2),YCT),(XYZT(3),ZCT)
  18.       EQUIVALENCE(XYZ2(1),XC2),(XYZ2(2),YC2),(XYZ2(3),ZC2)
  19.       EQUIVALENCE(XYZ3(1),XC3),(XYZ3(2),YC3),(XYZ3(3),ZC3)
  20.       EQUIVALENCE(XYZN(1),XN) ,(XYZN(2),YN) ,(XYZN(3),ZN)
  21. C
  22.       EQUIVALENCE(XYZ(1,1),XCA),(XYZ(2,1),YCA),(XYZ(3,1),ZCA)
  23.       EQUIVALENCE(XYZ(1,2),XCB),(XYZ(2,2),YCB),(XYZ(3,2),ZCB)
  24.       EQUIVALENCE(XYZ(1,3),XCC),(XYZ(2,3),YCC),(XYZ(3,3),ZCC)
  25.       EQUIVALENCE(XYZ(1,4),XCD),(XYZ(2,4),YCD),(XYZ(3,4),ZCD)
  26.       EQUIVALENCE(DIS(1),DI1),(DIS(2),DI2),(DIS(3),DI3),(DIS(4),DI4)
  27. C
  28.       PARAMETER(UN=1.D0,DEUX=2.D0,ZERO=0.D0)
  29. C
  30. C     LECTURE DES DONNEES
  31. C
  32.       IF (IDIM.NE.3) THEN
  33.         WRITE(IOIMP,*)'COUPE: You must be in 3D'
  34.         CALL ERREUR(0)
  35.         RETURN
  36.       ENDIF
  37. C
  38.       CALL LIROBJ('POINT',ICOUP1,1,IRETOU)
  39.       IF (IRETOU.EQ.0) RETURN
  40.       CALL LIROBJ('POINT',ICOUP2,1,IRETOU)
  41.       IF (IRETOU.EQ.0) RETURN
  42.       CALL LIROBJ('POINT',ICOUP3,1,IRETOU)
  43.       IF (IRETOU.EQ.0) RETURN
  44.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  45.       IF (IRETOU.EQ.0) RETURN
  46. C
  47. C     CARACTERISTIQUE DU PLAN DE COUPE
  48. C
  49.       SEGACT,MCOORD
  50.       IREF=(ICOUP1-1)*4
  51.       XCT=XCOOR(IREF+1)
  52.       YCT=XCOOR(IREF+2)
  53.       ZCT=XCOOR(IREF+3)
  54. C
  55.       IREF=(ICOUP2-1)*4
  56.       XC2=XCOOR(IREF+1)
  57.       YC2=XCOOR(IREF+2)
  58.       ZC2=XCOOR(IREF+3)
  59. C
  60.       IREF=(ICOUP3-1)*4
  61.       XC3=XCOOR(IREF+1)
  62.       YC3=XCOOR(IREF+2)
  63.       ZC3=XCOOR(IREF+3)
  64. C
  65.       TOL1=MIN(SQRT((XC2-XCT)**2+(YC2-YCT)**2+(ZC2-ZCT)**2),
  66.      >         SQRT((XC3-XCT)**2+(YC3-YCT)**2+(ZC3-ZCT)**2))/10
  67.       TOL4=TOL1/1000
  68. C :
  69.       XV=XC2-XCT
  70.       YV=YC2-YCT
  71.       ZV=ZC2-ZCT
  72.       XW=XC3-XCT
  73.       YW=YC3-YCT
  74.       ZW=ZC3-ZCT
  75.       XN=YV*ZW-ZV*YW
  76.       YN=ZV*XW-XV*ZW
  77.       ZN=XV*YW-YV*XW
  78.       RN=XN**2+YN**2+ZN**2
  79.       IF (RN.EQ.0.) CALL ERREUR(21)
  80.       IF (IERR.NE.0) RETURN
  81.       RN=SQRT(RN)
  82.       XN=XN/RN
  83.       YN=YN/RN
  84.       ZN=ZN/RN
  85. C
  86. C     PREPARATION DU MAILLAGE
  87. C
  88.       SEGACT,IPT1
  89.       MBSOUS=IPT1.LISOUS(/1)
  90.       IF(MBSOUS.EQ.0)THEN
  91.         NBSOUS=1
  92.         NBREF=0
  93.         NBNN=0
  94.         NBELEM=0
  95.         SEGINI,IPT2
  96.         IPT2.LISOUS(1)=IPT1
  97.       ELSE
  98.         SEGINI,IPT2=IPT1
  99.       ENDIF
  100.       SEGDES,IPT1
  101. C
  102. C     BOUCLE SUR LES ZONES DU MAILLAGE
  103. C
  104.       MBSOUS=IPT2.LISOUS(/1)
  105.       DO IE1=1,MBSOUS
  106. C
  107. C     -> REDUCTION DES MAILLAGES A 3 TYPES D'ELEMENTS (SEG2/TRI3/TET4)
  108. C
  109.         IPT1=IPT2.LISOUS(IE1)
  110.         SEGACT,IPT1
  111.         ITYP=IPT1.ITYPEL
  112.         ITYQ=0
  113. C CAS DES SEG3 QUE L'ON TRANFORME EN SEG2
  114.         IF(ITYP.EQ.3)THEN
  115.           ITYQ=2
  116.           CALL CHANGE(IPT1,ITYQ)
  117. C CAS DES TRI6, QUA4 ET QUA8 QUE L'ON TRANFORME EN TRI3
  118.         ELSEIF(ITYP.EQ.6.OR.ITYP.EQ.8.OR.ITYP.EQ.10)THEN
  119.           ITYQ=4
  120.           CALL CHANGE(IPT1,ITYQ)
  121. C CAS DES CUB8, CU20, PRI6, PR15, TE10, PYR5, PY13 QUE L'ON TRANFORME EN TET4
  122.         ELSEIF(ITYP.EQ.14.OR.ITYP.EQ.15.OR.ITYP.EQ.16.OR.ITYP.EQ.17
  123.      &     .OR.ITYP.EQ.24.OR.ITYP.EQ.25.OR.ITYP.EQ.26)THEN
  124.           ITYQ=23
  125.           CALL CHANGE(IPT1,ITYQ)
  126.         ENDIF
  127.         ITYP=IPT1.ITYPEL
  128.         NBELEM=IPT1.NUM(/2)
  129.         MBELEM=NBELEM
  130.         NBREF=0
  131.         NBSOUS=0
  132. C
  133. C     -> AIGUILLAGE SUR LES TYPES D'ELEMENTS
  134. C
  135.         IF(ITYP.EQ.2)THEN
  136. C
  137. C     --> TRAVAIL SUR LES SEG2 (--> SEG2 OR POI1)
  138. C
  139.           NBNN=1
  140.           SEGINI,MELEME
  141.           ITYPEL=1
  142. C
  143.           NBNN=2
  144.           SEGINI,IPT3
  145.           IPT3.ITYPEL=2
  146. C
  147.           NBELEM=0
  148.           NBELE3=0
  149. C
  150.           DO IE2=1,MBELEM
  151.             JCOLOR=IPT1.ICOLOR(IE2)
  152.             DO IE3=1,2
  153.               IREF=(IPT1.NUM(IE3,IE2)-1)*4
  154.               DO IE4=1,3+1
  155.                 XYZ(IE4,IE3)=XCOOR(IREF+IE4)
  156.               ENDDO
  157.               CALL COUPEC(XYZ(1,IE3),XYZT,XYZ2,XYZ3,XYZN,TOL1, DIS(IE3))
  158.             ENDDO
  159. C     COTE DANS LE PLAN DE COUPE
  160.             IF    (ABS(DI1)+ABS(DI2).LT.TOL4)THEN
  161.               NBELE3=NBELE3+1
  162.               IPT3.NUM(1,NBELE3)=IPT1.NUM(1,IE2)
  163.               IPT3.NUM(2,NBELE3)=IPT1.NUM(2,IE2)
  164.               IPT3.ICOLOR(NBELE3)=JCOLOR
  165. C
  166.             ELSEIF(SIGN(UN,DI1)+SIGN(UN,DI2).EQ.ZERO .OR.
  167.      >             ABS(DI1).LT.TOL4 .OR. ABS(DI2).LT.TOL4)THEN
  168. C     INTERSECTION OU POINT DANS LE PLAN DE COUPE
  169.               segact mcoord*mod
  170.               NBPTI=NBPTS
  171.               NBPTS=NBPTI+1
  172.               SEGADJ,MCOORD
  173. C
  174.               COEFF=ABS(DI1)/(ABS(DI1)+ABS(DI2))
  175.               NBPTI=NBPTI+1
  176.               IREF=(NBPTI-1)*4
  177.               DO IE3=1,4
  178.                 XCOOR(IREF+IE3)=XYZ(1,IE3)+COEFF*(XYZ(2,IE3)-XYZ(1,IE3))
  179.               ENDDO
  180. C
  181.               NBELEM=NBELEM+1
  182.               NUM(1,NBELEM)=NBPTI
  183.               ICOLOR(NBELEM)=JCOLOR
  184.             ENDIF
  185.           ENDDO
  186. C     STOCKAGE EVENTUEL DU MAILLAGE SUPLEMENTAIRE
  187.           IF(NBELEM.EQ.0)THEN
  188.             SEGSUP,MELEME
  189.             NBELEM=NBELE3
  190.             MELEME=IPT3
  191.             SEGADJ,MELEME
  192.           ELSE
  193.             NBNN=1
  194.             SEGADJ,MELEME
  195.             NBELEM=NBELE3
  196.             NBNN=2
  197.             SEGADJ,IPT3
  198. C
  199.             NBELEM=0
  200.             NBNN=0
  201.             NBSOUS=IPT2.LISOUS(/1)+1
  202.             SEGADJ,IPT2
  203.             IPT2.LISOUS(NBSOUS)=IPT3
  204.           ENDIF
  205.         ELSE IF(ITYP.EQ.4)THEN
  206. C
  207. C     --> TRAVAIL SUR LES TRI3 (--> TRI3 OR SEG2)
  208. C
  209.           NBNN=2
  210.           SEGINI,MELEME
  211.           ITYPEL=2
  212.           NBELEM=0
  213.           DO IE2=1,MBELEM
  214. C         A FAIRE......
  215.           ENDDO
  216.           SEGADJ,MELEME
  217.         ELSE IF(ITYP.EQ.23)THEN
  218. C
  219. C     --> TRAVAIL SUR LES TET4 (--> TRI3)
  220. C
  221.           NBELEM=NBELEM*2
  222.           NBNN=3
  223.           SEGINI,MELEME
  224.           ITYPEL=4
  225.           NBELEM=0
  226. C
  227.           DO IE2=1,MBELEM
  228.             JCOLOR=IPT1.ICOLOR(IE2)
  229.             DO IE3=1,4
  230.               IREF=(IPT1.NUM(IE3,IE2)-1)*4
  231.               DO IE4=1,3+1
  232.                 XYZ(IE4,IE3)=XCOOR(IREF+IE4)
  233.               ENDDO
  234.               CALL COUPEC(XYZ(1,IE3),XYZT,XYZ2,XYZ3,XYZN,TOL1, DIS(IE3))
  235.             ENDDO
  236. C
  237.             IF    (ABS(DIS(1))+ABS(DIS(2))+ABS(DIS(3)).LT.TOL4)THEN
  238. C     FACE 1 DS LE PLAN DE COUPE
  239.               NBELEM=NBELEM+1
  240.               NUM(1,NBELEM)=IPT1.NUM(1,IE2)
  241.               NUM(2,NBELEM)=IPT1.NUM(2,IE2)
  242.               NUM(3,NBELEM)=IPT1.NUM(3,IE2)
  243.               ICOLOR(NBELEM)=JCOLOR
  244.             ELSEIF(ABS(DIS(1))+ABS(DIS(2))+ABS(DIS(4)).LT.TOL4)THEN
  245. C     FACE 2 DS LE PLAN DE COUPE
  246.               NBELEM=NBELEM+1
  247.               NUM(1,NBELEM)=IPT1.NUM(1,IE2)
  248.               NUM(2,NBELEM)=IPT1.NUM(2,IE2)
  249.               NUM(3,NBELEM)=IPT1.NUM(4,IE2)
  250.               ICOLOR(NBELEM)=JCOLOR
  251.             ELSEIF(ABS(DIS(1))+ABS(DIS(3))+ABS(DIS(4)).LT.TOL4)THEN
  252. C     FACE 3 DS LE PLAN DE COUPE
  253.               NBELEM=NBELEM+1
  254.               NUM(1,NBELEM)=IPT1.NUM(1,IE2)
  255.               NUM(2,NBELEM)=IPT1.NUM(3,IE2)
  256.               NUM(3,NBELEM)=IPT1.NUM(4,IE2)
  257.               ICOLOR(NBELEM)=JCOLOR
  258.             ELSEIF(ABS(DIS(2))+ABS(DIS(3))+ABS(DIS(4)).LT.TOL4)THEN
  259. C     FACE 4 DS LE PLAN DE COUPE
  260.               NBELEM=NBELEM+1
  261.               NUM(1,NBELEM)=IPT1.NUM(2,IE2)
  262.               NUM(2,NBELEM)=IPT1.NUM(3,IE2)
  263.               NUM(3,NBELEM)=IPT1.NUM(4,IE2)
  264.               ICOLOR(NBELEM)=JCOLOR
  265.             ELSEIF(ABS(DI1)+ABS(DI2).LT.TOL4)THEN
  266. C     COTE 12 DS LE PLAN DE COUPE
  267.               DINDEX=SIGN(UN,DI3)+SIGN(UN,DI4)
  268.               IF(DINDEX.EQ.0)THEN
  269.                 NUMA=IPT1.NUM(1,IE2)
  270.                 NUMB=IPT1.NUM(2,IE2)
  271.                 CALL COUPEM(XYZ(1,3),XYZ(1,4),DI3,DI4,
  272.      >                      NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  273.               ENDIF
  274.             ELSEIF(ABS(DI1)+ABS(DI3).LT.TOL4)THEN
  275. C     COTE 13 DS LE PLAN DE COUPE
  276.               DINDEX=SIGN(UN,DI2)+SIGN(UN,DI4)
  277.               IF(DINDEX.EQ.0)THEN
  278.                 NUMA=IPT1.NUM(1,IE2)
  279.                 NUMB=IPT1.NUM(3,IE2)
  280.                 CALL COUPEM(XYZ(1,2),XYZ(1,4),DI2,DI4,
  281.      >                      NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  282.               ENDIF
  283.             ELSEIF(ABS(DI1)+ABS(DI4).LT.TOL4)THEN
  284. C     COTE 14 DS LE PLAN DE COUPE
  285.               DINDEX=SIGN(UN,DI2)+SIGN(UN,DI3)
  286.               IF(DINDEX.EQ.0)THEN
  287.                 NUMA=IPT1.NUM(1,IE2)
  288.                 NUMB=IPT1.NUM(4,IE2)
  289.                 CALL COUPEM(XYZ(1,2),XYZ(1,3),DI2,DI3,
  290.      >                      NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  291.               ENDIF
  292.             ELSEIF(ABS(DI2)+ABS(DI3).LT.TOL4)THEN
  293. C     COTE 23 DS LE PLAN DE COUPE
  294.               DINDEX=SIGN(UN,DI1)+SIGN(UN,DI4)
  295.               IF(DINDEX.EQ.0)THEN
  296.                 NUMA=IPT1.NUM(2,IE2)
  297.                 NUMB=IPT1.NUM(3,IE2)
  298.                 CALL COUPEM(XYZ(1,1),XYZ(1,4),DI1,DI4,
  299.      >                      NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  300.               ENDIF
  301.             ELSEIF(ABS(DI2)+ABS(DI4).LT.TOL4)THEN
  302. C     COTE 24 DS LE PLAN DE COUPE
  303.               DINDEX=SIGN(UN,DI1)+SIGN(UN,DI3)
  304.               IF(DINDEX.EQ.0)THEN
  305.                 NUMA=IPT1.NUM(2,IE2)
  306.                 NUMB=IPT1.NUM(4,IE2)
  307.                 CALL COUPEM(XYZ(1,1),XYZ(1,3),DI1,DI3,
  308.      >                      NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  309.               ENDIF
  310.             ELSEIF(ABS(DI3)+ABS(DI4).LT.TOL4)THEN
  311. C     COTE 34 DS LE PLAN DE COUPE
  312.               DINDEX=SIGN(UN,DI1)+SIGN(UN,DI2)
  313.               IF(DINDEX.EQ.0)THEN
  314.                 NUMA=IPT1.NUM(3,IE2)
  315.                 NUMB=IPT1.NUM(4,IE2)
  316.                 CALL COUPEM(XYZ(1,1),XYZ(1,2),DI1,DI2,
  317.      >                      NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  318.               ENDIF
  319.             ELSEIF(ABS(DI1).LT.TOL4)THEN
  320. C     POINT 1 DANS LE PLAN DE COUPE
  321.               DINDEX=SIGN(UN,DI2)+SIGN(UN,DI3)+SIGN(UN,DI4)
  322.               IF(ABS(DINDEX).EQ.UN)THEN
  323.                 NUM0=IPT1.NUM(1,IE2)
  324.                 CALL COUPEK(XYZ(1,2),XYZ(1,3),XYZ(1,4),
  325.      >                          DI2 ,    DI3 ,    DI4,
  326.      >                      NUM0,MELEME,NBELEM,JCOLOR)
  327.               ENDIF
  328.             ELSE IF(ABS(DI2).LT.TOL4)THEN
  329. C     POINT 2 DANS LE PLAN DE COUPE
  330.               DINDEX=SIGN(UN,DI3)+SIGN(UN,DI4)+SIGN(UN,DI1)
  331.               IF(ABS(DINDEX).EQ.UN)THEN
  332.                 NUM0=IPT1.NUM(2,IE2)
  333.                 CALL COUPEK(XYZ(1,3),XYZ(1,4),XYZ(1,1),
  334.      >                          DI3 ,    DI4 ,    DI1,
  335.      >                      NUM0,MELEME,NBELEM,JCOLOR)
  336.               ENDIF
  337.             ELSE IF(ABS(DI3).LT.TOL4)THEN
  338. C     POINT 3 DANS LE PLAN DE COUPE
  339.               DINDEX=SIGN(UN,DI4)+SIGN(UN,DI1)+SIGN(UN,DI2)
  340.               IF(ABS(DINDEX).EQ.UN)THEN
  341.                 NUM0=IPT1.NUM(3,IE2)
  342.                 CALL COUPEK(XYZ(1,4),XYZ(1,1),XYZ(1,2),
  343.      >                          DI4 ,    DI1 ,    DI2,
  344.      >                      NUM0,MELEME,NBELEM,JCOLOR)
  345.               ENDIF
  346.             ELSE IF(ABS(DI4).LT.TOL4)THEN
  347. C     POINT 4 DANS LE PLAN DE COUPE
  348.               DINDEX=SIGN(UN,DI1)+SIGN(UN,DI2)+SIGN(UN,DI3)
  349.               IF(ABS(DINDEX).EQ.UN)THEN
  350.                 NUM0=IPT1.NUM(4,IE2)
  351.                 CALL COUPEK(XYZ(1,1),XYZ(1,2),XYZ(1,3),
  352.      >                          DI1 ,    DI2 ,    DI3,
  353.      >                      NUM0,MELEME,NBELEM,JCOLOR)
  354.               ENDIF
  355.             ELSE
  356.               DINDEX=SIGN(UN,DI1)+SIGN(UN,DI2)+SIGN(UN,DI3)+SIGN(UN,DI4)
  357.               IF(ABS(DINDEX).EQ.DEUX)THEN
  358. C     INTERSECTION PAR UNE POINTE
  359.                 IF(SIGN(UN,DI1).NE.SIGN(UN,DINDEX))THEN
  360. C     POINTE N.1
  361.                   CALL COUPEI(XYZ(1,1),XYZ(1,2),XYZ(1,3),XYZ(1,4),
  362.      >                            DI1 ,    DI2 ,    DI3 ,    DI4,
  363.      >                        MELEME,NBELEM,JCOLOR)
  364.                 ELSE IF(SIGN(UN,DI2).NE.SIGN(UN,DINDEX))THEN
  365. C     POINTE N.2
  366.                   CALL COUPEI(XYZ(1,2),XYZ(1,3),XYZ(1,4),XYZ(1,1),
  367.      >                            DI2 ,    DI3 ,    DI4 ,    DI1,
  368.      >                        MELEME,NBELEM,JCOLOR)
  369.                 ELSE IF(SIGN(UN,DI3).NE.SIGN(UN,DINDEX))THEN
  370. C     POINTE N.3
  371.                   CALL COUPEI(XYZ(1,3),XYZ(1,4),XYZ(1,1),XYZ(1,2),
  372.      >                            DI3 ,    DI4 ,    DI1 ,    DI2,
  373.      >                        MELEME,NBELEM,JCOLOR)
  374.                 ELSE IF(SIGN(UN,DI4).NE.SIGN(UN,DINDEX))THEN
  375. C     POINTE N.4
  376.                   CALL COUPEI(XYZ(1,4),XYZ(1,1),XYZ(1,2),XYZ(1,3),
  377.      >                            DI4 ,    DI1 ,    DI2 ,    DI3,
  378.      >                        MELEME,NBELEM,JCOLOR)
  379. C     ERREUR
  380.                 ELSE
  381. C         A FAIRE......
  382.                 ENDIF
  383.               ELSEIF(ABS(DINDEX).EQ.ZERO)THEN
  384. C     INTERSECTION PAR UN COTE
  385.                 IF(SIGN(UN,DI1).EQ.SIGN(UN,DI2))THEN
  386. C     COTE 12
  387.                   CALL COUPEJ(XYZ(1,1),XYZ(1,2),XYZ(1,3),XYZ(1,4),
  388.      >                            DI1 ,    DI2 ,    DI3 ,    DI4,
  389.      >                        MELEME,NBELEM,JCOLOR)
  390.                 ELSE IF(SIGN(UN,DI1).EQ.SIGN(UN,DI3))THEN
  391. C     COTE 13
  392.                   CALL COUPEJ(XYZ(1,1),XYZ(1,3),XYZ(1,2),XYZ(1,4),
  393.      >                            DI1 ,    DI3 ,    DI2 ,    DI4,
  394.      >                        MELEME,NBELEM,JCOLOR)
  395.                 ELSE IF(SIGN(UN,DI1).EQ.SIGN(UN,DI4))THEN
  396. C     COTE 14
  397.                   CALL COUPEJ(XYZ(1,1),XYZ(1,4),XYZ(1,2),XYZ(1,3),
  398.      >                            DI1 ,    DI4 ,    DI2 ,    DI3,
  399.      >                        MELEME,NBELEM,JCOLOR)
  400.                 ELSE IF(SIGN(UN,DI2).EQ.SIGN(UN,DI3))THEN
  401. C     COTE 23
  402.                   CALL COUPEJ(XYZ(1,2),XYZ(1,3),XYZ(1,1),XYZ(1,4),
  403.      >                            DI2 ,    DI3 ,    DI1 ,    DI4,
  404.      >                        MELEME,NBELEM,JCOLOR)
  405.                 ELSE IF(SIGN(UN,DI2).EQ.SIGN(UN,DI4))THEN
  406. C     COTE 24
  407.                   CALL COUPEJ(XYZ(1,2),XYZ(1,4),XYZ(1,1),XYZ(1,3),
  408.      >                            DI2 ,    DI4 ,    DI1 ,    DI3,
  409.      >                        MELEME,NBELEM,JCOLOR)
  410.                 ELSE IF(SIGN(UN,DI3).EQ.SIGN(UN,DI4))THEN
  411. C     COTE 34
  412.                   CALL COUPEJ(XYZ(1,3),XYZ(1,4),XYZ(1,1),XYZ(1,2),
  413.      >                            DI3 ,    DI4 ,    DI1 ,    DI2,
  414.      >                        MELEME,NBELEM,JCOLOR)
  415. C     ERREUR
  416.                 ELSE
  417. C         A FAIRE......
  418.                 ENDIF
  419.               ENDIF
  420.             ENDIF
  421.           ENDDO
  422.           SEGADJ,MELEME
  423. C     ELIMINATION DES DOUBLONS (FACE DANS LE PLAN)
  424. C     (on fait un tri prealable)
  425.           JG=NBELEM
  426.           SEGINI,MLENT1,MLENTI
  427.           DO IE2=1,NBELEM
  428.             LECT(IE2)=IE2
  429.             MLENT1.LECT(IE2)=0
  430.             DO IE3=1,NBNN
  431.               MLENT1.LECT(IE2)=MLENT1.LECT(IE2)+NUM(IE3,IE2)
  432.             ENDDO
  433.           ENDDO
  434.           SEGINI,MLENT2=MLENTI
  435. C
  436.           CALL GENOR2(MLENT1.LECT,MLENT2.LECT,NBELEM)
  437. C
  438.           IDIMP1=IDIM+1
  439.           segact mcoord*mod
  440.           CALL COUPEN(NUM,NBNN,NBELEM,XCOOR,IDIMP1,NBPTS,
  441.      >                MLENT1.LECT,MLENT2.LECT,LECT)
  442. C
  443.           MBELEM=0
  444.           DO IE2=1,NBELEM
  445.             IF(LECT(IE2).NE.0)THEN
  446.               IF(LECT(IE2).NE.IE2)THEN
  447.                 LECT(LECT(IE2))=0
  448.               ENDIF
  449.               MBELEM=MBELEM+1
  450.               DO IE3=1,NBNN
  451.                 NUM(IE3,MBELEM)=NUM(IE3,IE2)
  452.               ENDDO
  453.               ICOLOR(MBELEM) =ICOLOR(IE2)
  454.             ENDIF
  455.           ENDDO
  456. C
  457.           SEGSUP,MLENTI,MLENT1,MLENT2
  458.           NBELEM=MBELEM
  459.           SEGADJ,MELEME
  460. C
  461.         ELSE
  462. C
  463. C     --> ERREUR
  464. C
  465.           WRITE(IOIMP,*)'COUPE: Incorrect type of element',ITYP
  466. C         SEGSUP,MELEME
  467.           IF(IE1.GT.1)THEN
  468.             DO IE2=1,IE1-1
  469.               MELEME=IPT2.LISOUS(IE2)
  470.               SEGSUP,MELEME
  471.             ENDDO
  472.           ENDIF
  473.           SEGSUP,IPT2
  474.           CALL ERREUR(0)
  475.           RETURN
  476.         ENDIF
  477. C
  478. C     FIN BOUCLE SUR LES ZONES DU MAILLAGE
  479. C
  480. C       SEGDES,MELEME
  481.         IPT2.LISOUS(IE1)=MELEME
  482.         IF(ITYQ.NE.0)SEGSUP,IPT1
  483.       ENDDO
  484. C
  485. C     ON TASSE LE MAILLAGE POUR ELIMINER LES ZONES VIDES
  486. C
  487.       MELEME=IPT2
  488.       NBSOUS=0
  489.       DO IE1=1,LISOUS(/1)
  490.         IPT1=LISOUS(IE1)
  491.         NBELEM=IPT1.NUM(/2)
  492.         IF(NBELEM.EQ.0)THEN
  493.           SEGSUP,IPT1
  494.         ELSE
  495.           NBSOUS=NBSOUS+1
  496.           LISOUS(NBSOUS)=IPT1
  497.           SEGDES,IPT1
  498.         ENDIF
  499.       ENDDO
  500.       NBNN=0
  501.       NBELEM=0
  502.       NBREF=0
  503.       SEGADJ,MELEME
  504. C
  505. C     SI LE MAILLAGE NE CONTIENT QU'UNE SEULE ZONE...
  506. C
  507.       IF(NBSOUS.EQ.1)THEN
  508.         IPT1=LISOUS(1)
  509.         SEGSUP,MELEME
  510.         MELEME=IPT1
  511.       ELSE
  512.         SEGDES,MELEME
  513.       ENDIF
  514. C
  515.       CALL ECROBJ('MAILLAGE',MELEME)
  516.       RETURN
  517.       END
  518.  
  519.  
  520.  
  521.  
  522.  
  523.  
  524.  
  525.  
  526.  
  527.  

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