C MOCR      SOURCE    PV        20/03/25    08:13:59     10554          
C   MODI CREATION D'ELEMENT
C
      SUBROUTINE MOCR(XPROJ,IVU,IDCP,MELEME,ICPR,ITE,IMILL,TMIN,IBOUJ)
      IMPLICIT INTEGER(I-N)
      COMMON/CMODI/LIGMAX,XDEC,YDEC
-INC SMELEME

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCOORD
      DIMENSION XTR(10),YTR(10),ZTR(10)
      SEGMENT XPROJ(3,ITE)
      SEGMENT IVU(ITE)
      SEGMENT IDCP(ITE)
      SEGMENT ICPR(0)
      SEGMENT IMILL(ITE)
      SEGMENT IBOUJ(0)
      CHARACTER*4 LEGEND(11)
      CHARACTER*8 ZONE
      do i=1,10
       ztr(i)=0
      enddo
      XPR=XDEC**2
      TTEMP=TMIN
  10  CONTINUE
      CALL TRMESS('Choisissez le type d''element')
      LEGEND(1)=' '
      LEGEND(2)='POI1'
      LEGEND(3)='SEG2'
      LEGEND(4)='SEG3'
      LEGEND(5)='TRI3'
      LEGEND(6)=' '
      LEGEND(7)='TRI6'
      LEGEND(8)=' '
      LEGEND(9)='QUA4'
      LEGEND(10)=' '
      LEGEND(11)='QUA8'
      CALL MENU(LEGEND,11,4)
      CALL TRAFF(ICLE)
      IF (ICLE.NE.2.AND.ICLE.NE.3.AND.ICLE.NE.4.AND.ICLE.NE.6
     # .AND.ICLE.NE.8.AND.ICLE.NE.10.AND.ICLE.NE.1) THEN
      GOTO 10
      ENDIF
      IF (KDEGRE(ICLE).EQ.3) THEN
*  IL FAUT INDIQUER OU SONT LES POINTS MILIEUX
      call insegt(3,iresu)
      CALL CHCOUL(IDNOIR)
      IPT1=MELEME
      DO 30 IO=1,MAX(1,LISOUS(/1))
      IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
      IF (KDEGRE(IPT1.ITYPEL).NE.3) GOTO 40
      DO 50 I=1,IPT1.NUM(/1)
      DO 50 J=1,IPT1.NUM(/2)
      IP=ICPR(IPT1.NUM(I,J))
      IF (IMILL(IP).NE.0) GOTO 50
      XTR(1)=XPROJ(1,IP)
      YTR(1)=XPROJ(2,IP)
      XTR(2)=XPROJ(1,IP)
      YTR(2)=XPROJ(2,IP)
      CALL POLRL(2,XTR,YTR,ZTR)
      IMILL(IP)=1
  50  CONTINUE
  40  CONTINUE
  30  CONTINUE
      ENDIF
      NBELEM=0
      NBSOUS=0
      NBREF=0
      NBNN=NBNNE(ICLE)
      SEGINI IPT8
      IPT8.ITYPEL=ICLE
 100  CONTINUE
      CALL TRMESS('Pointez les points de l''element')
      NBELEM=NBELEM+1
      SEGADJ IPT8
      CALL CHCOUL(5)
      DO 110 I=1,NBNN
      CALL TRDIG(X,Y,INCLE)
      IF (INCLE.EQ.3) GOTO 141
       DO 120 IP=1,ITE
        IF (IVU(IP).NE.1) GOTO 120
        IF((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LT.XPR) GOTO 130
 120   CONTINUE
       ITE=ITE+1
       SEGADJ XPROJ
       XPROJ(1,ITE)=X
       XPROJ(2,ITE)=Y
       XPROJ(3,ITE)=TTEMP
       XCOOR(**)=X
       XCOOR(**)=Y
       IF (IDIM.EQ.3) XCOOR(**)=TTEMP
       XCOOR(**)=DENSIT
       nbpts=nbpts+1
       IP=ITE
       ICPR(**)=ITE
       III=ICPR(/1)
       IDCP(**)=III
       IVU(**)=1
       IMILL(**)=0
       CALL PROMOD(ICPR,XPROJ,III,4,IBOUJ)
 130   CONTINUE
      call insegt(3,iresu)
      TTEMP=XPROJ(3,IP)
       XTR(I)=XPROJ(1,IP)
       YTR(I)=XPROJ(2,IP)
       IF (I.NE.1) CALL POLRL(2,XTR(I-1),YTR(I-1),ZTR)
      IF (I.EQ.NBNN.AND.IPT8.ITYPEL.GT.3) THEN
       XTR(2)=XTR(I)
       YTR(2)=YTR(I)
       CALL POLRL(2,XTR,YTR,ZTR)
      ENDIF
      IPT8.NUM(I,NBELEM)=IDCP(IP)
 110  CONTINUE
      IPT8.ICOLOR(NBELEM)=IDCOUL
      CALL CHCOUL(IDNOIR)
      DO 140 I=1,NBNN
       IPR=ICPR(IPT8.NUM(I,NBELEM))
       XTR(1)=XPROJ(1,IPR)
       YTR(1)=XPROJ(2,IPR)
       XTR(2)=XPROJ(1,IPR)
       YTR(2)=XPROJ(2,IPR)
       CALL POLRL(2,XTR,YTR,ZTR)
       IMILL(IPR)=1
 140  CONTINUE
 141  CONTINUE
      LEGEND(1)=' '
      LEGEND(2)='Fin'
      LEGEND(3)='Cont'
      CALL MENU(LEGEND,3,4)
      CALL TRMESS('Fin pour arreter la definition d''elements')
      CALL TRAFF(IREP)
      IF (IREP.NE.1) GOTO 100
      CALL TRGET
     * ('Donnez si necessaire un nom aux elements crees :',ZONE)
      IF (ZONE(1:1).NE.' ') THEN
       CALL NOMOBJ('MAILLAGE',ZONE,IPT8)
      ENDIF
      LEGEND(1)=' '
      LEGEND(2)='Ajou'
      LEGEND(3)='Cont'
      CALL MENU(LEGEND,3,4)
      CALL TRMESS('Ajou pour ajouter le maillage au maillage courant')
      CALL TRAFF(IREP)
      IF (IREP.NE.1) THEN
        SEGDES IPT8
        RETURN
      ENDIF
      IF (LISOUS(/1).EQ.0) THEN
       IF (ITYPEL.EQ.IPT8.ITYPEL) THEN
        NBELE0=NUM(/2)
        NBELE8=IPT8.NUM(/2)
        NBELEM=NBELE0+NBELE8
        NBNN=NUM(/1)
        NBREF=0
        NBSOUS=0
        SEGADJ MELEME
        DO 800 I=NBELE0+1,NBELEM
        ICOLOR(I)=IPT8.ICOLOR(I-NBELE0)
        DO 800 J=1,NBNN
        NUM(J,I)=IPT8.NUM(J,I-NBELE0)
 800    CONTINUE
        SEGDES IPT8
        RETURN
       ENDIF
       SEGINI,IPT2=MELEME
       NBSOUS=2
       NBREF=0
       NBNN=0
       NBELEM=0
       SEGADJ MELEME
       ITYPEL=0
       LISOUS(1)=IPT2
       LISOUS(2)=IPT8
       RETURN
      ENDIF
      DO 810 IO=1,LISOUS(/1)
      IPT1=LISOUS(IO)
      IF (IPT1.ITYPEL.NE.IPT8.ITYPEL) GOTO 810
        NBELE1=IPT1.NUM(/2)
        NBELE8=IPT8.NUM(/2)
        NBELEM=NBELE1+NBELE8
        NBNN=IPT1.NUM(/1)
        NBREF=0
        NBSOUS=0
        SEGADJ IPT1
        DO 820 I=NBELE1+1,NBELEM
        IPT1.ICOLOR(I)=IPT8.ICOLOR(I-NBELE1)
        DO 820 J=1,NBNN
        IPT1.NUM(J,I)=IPT8.NUM(J,I-NBELE1)
 820    CONTINUE
        SEGDES IPT8
        RETURN
 810  CONTINUE
      NBELEM=0
      NBREF=0
      NBSOUS=LISOUS(/1)+1
      NBNN=0
      SEGADJ MELEME
      LISOUS(NBSOUS)=IPT8
      END