C MONL      SOURCE    BP208322  16/11/18    21:19:28     9177           
C  MODI NOMMER UN ELEMENT
C
      SUBROUTINE MONL(XPROJ,IVU,ICPR,IPTZ)
      IMPLICIT INTEGER(I-N)
-INC CCREEL
-INC SMELEME

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
      DIMENSION XTR(40),YTR(40),ztr(40)
      CHARACTER*8 ZONE
      CHARACTER*19 LEGEND(3)
      COMMON/CMODI/LIGMAX,XDEC,YDEC
      SEGMENT IVU(0)
      SEGMENT XPROJ(3,0)
      SEGMENT ICPR(0)
      SEGMENT ISOM(NBSO)
      do i=1,40
        ztr(i)=0
      enddo
      IPT1=IPTZ
      XDPR=XDEC**2
 11   CONTINUE
      LEGEND(1)=' '
      LEGEND(2)='Element du maillage'
      LEGEND(3)='Element du contour'
      CALL MENU(LEGEND,3,19)
      CALL TRAFF(ICLE)
      IF (ICLE.NE.1.AND.ICLE.NE.2) GOTO 11
      IF (ICLE.EQ.2) THEN
         CALL ECROBJ('MAILLAGE',IPT1)
         CALL PRCONT
         CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
         IF (IERR.NE.0) RETURN
*  REACTIVONS LE  MAILLAGE A TOUT HASARD
         SEGACT IPT1
         DO 101 I=1,IPT1.LISOUS(/1)
            IPT2=IPT1.LISOUS(I)
            SEGACT IPT2
 101     CONTINUE
         SEGACT MELEME
         NBELEM=NUM(/2)
         NBNN=NUM(/1)
         CALL CHCOUL(1)
         ICOUR=0
         ITR=1
         DO 10 J=1,NBELEM
            DO 20 I=1,NBNN-1
               IP=ICPR(NUM(I,J))
               IP1=ICPR(NUM(I+1,J))
               IF (IVU(IP).NE.1) GOTO 20
               IF (IVU(IP1).NE.1) GOTO 20
               IF (ICOUR.NE.IP) THEN
                  IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
                  ITR=1
                  XTR(1)=XPROJ(1,IP)
                  YTR(1)=XPROJ(2,IP)
               ENDIF
               ITR=ITR+1
               XTR(ITR)=XPROJ(1,IP1)
               YTR(ITR)=XPROJ(2,IP1)
               IF (ITR.EQ.40) THEN
                  CALL POLRL(ITR,XTR,YTR,ZTR)
                  XTR(1)=XTR(ITR)
                  YTR(1)=YTR(ITR)
                  ITR=1
               ENDIF
               ICOUR=IP1
 20         CONTINUE
 10      CONTINUE
         CALL POLRL(ITR,XTR,YTR,ZTR)
         ITR=1
 40      CONTINUE
         CALL TRMESS('Pointez la premiere extremite')
         CALL MOPF3
         CALL TRDIG(X,Y,INCLE)
         IF (INCLE.EQ.3) RETURN
         DO 80 IL=1,NUM(/2)
            IPT=NUM(1,IL)
            IP=ICPR(IPT)
            IF (IVU(IP).NE.1) GOTO 80
            IF ((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LE.XDPR) GOTO 30
 80      CONTINUE
         GOTO 40
 30      IP1 = IPT
 70      CONTINUE
         CALL TRMESS('Pointez la deuxieme extremite')
         CALL MOPF3
         CALL TRDIG(X,Y,INCLE)
         IF (INCLE.EQ.3) RETURN
         DO 50 IL=1,NUM(/2)
            IPT=NUM(1,IL)
            IP=ICPR(IPT)
            IF (IVU(IP).NE.1) GOTO 50
            IF ((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LE.XDPR) GOTO 60
 50      CONTINUE
         GOTO 70
 60      IP2=IPT
         CALL ECROBJ ('POINT   ',IP2)
         CALL ECROBJ ('POINT   ',IP1)
         CALL ECROBJ ('MAILLAGE',MELEME)
         CALL COMPRI
         CALL LIROBJ ( 'MAILLAGE',IPT2,1,IRETOU)
         IF(IERR.NE.0) RETURN
         SEGDES MELEME
         MELEME=IPT2
         SEGACT MELEME
         NBELEM=NUM(/2)
         NBNN=NUM(/1)
         CALL CHCOUL(6)
         ICOUR=0
         ITR=1
         DO 100 J=1,NBELEM
            DO 110 I=1,NBNN-1
               IP=ICPR(NUM(I,J))
               IP1=ICPR(NUM(I+1,J))
               IF (IVU(IP).NE.1) GOTO 110
               IF (IVU(IP1).NE.1) GOTO 110
               IF (ICOUR.NE.IP) THEN
                  IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
                  ITR=1
                  XTR(1)=XPROJ(1,IP)
                  YTR(1)=XPROJ(2,IP)
               ENDIF
               ITR=ITR+1
               XTR(ITR)=XPROJ(1,IP1)
               YTR(ITR)=XPROJ(2,IP1)
               IF (ITR.EQ.40) THEN
                  CALL POLRL(ITR,XTR,YTR,ZTR)
                  XTR(1)=XTR(ITR)
                  YTR(1)=YTR(ITR)
                  ITR=1
               ENDIF
               ICOUR=IP1
 110        CONTINUE
 100     CONTINUE
         CALL POLRL(ITR,XTR,YTR,ZTR)
         ITR=1
         CALL TRGET('Donnez un nom si necessaire :',ZONE)
         IF (ZONE(1:1).EQ.' ') THEN
            SEGSUP MELEME
            RETURN
         ENDIF
         CALL NOMOBJ('MAILLAGE',ZONE,MELEME)
         RETURN
      ENDIF
*  RECHERCHE D'ELEMENT
      IPPT=0
      IEEL=0
*  ON CREE UN RESULTAT VIDE POUR RECEUILLIR LES ELEMENTS DESIGNES
      NBNN=0
      NBELEM=0
      NBSOUS=0
      NBREF=0
      SEGINI IPT8
      MELEME=IPT1
      CALL TRMESS('Pointez les elements a nommer. Pointez 2 fois le '
     #     //'meme pour terminer')
 400  CONTINUE
      CALL TRDIG(XP,YP,INCLE)
      IF (INCLE.EQ.3) GOTO 650
      IPT1=MELEME
      SEGACT IPT1
      DO 220 IO=1,MAX(1,LISOUS(/1))
         IF (LISOUS(/1).NE.0) THEN
            IPT1=LISOUS(IO)
            SEGACT IPT1
         ENDIF
         NBNN=IPT1.NUM(/1)
         IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 260
*  C'EST UNE LIGNE
         DO 240 J=1,IPT1.NUM(/2)
            IA=ICPR(IPT1.NUM(1,J))
            IB=ICPR(IPT1.NUM(NBNN,J))
            IF (IVU(IA).NE.1) GOTO 240
            IF (IVU(IB).NE.1) GOTO 240
            XA=XPROJ(1,IA)
            YA=XPROJ(2,IA)
            XB=XPROJ(1,IB)
            YB=XPROJ(2,IB)
            SCA=(XP-XA)*(XP-XB)+(YP-YA)*(YP-YB)
            IF (SCA.LE.0.) GOTO 500
 240     CONTINUE
         GOTO 1000
 260     IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 1000
*  C'EST UNE SURFACE
         NBSO = NBSOM(IPT1.ITYPEL)
         IF (NBSO.EQ.0) THEN
C       Polygone a N cotes
            NBSO = IPT1.NUM(/1)
         ENDIF
         SEGINI ISOM
         DO 261 I=1,ISOM(/1)
            ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I)
 261     CONTINUE
         DO 262 J=1,IPT1.NUM(/2)
            I1=ICPR(IPT1.NUM(ISOM(1),J))
            I2=ICPR(IPT1.NUM(ISOM(2),J))
            I3=ICPR(IPT1.NUM(ISOM(3),J))
            IF (IVU(I1).NE.1) GOTO 262
            IF (IVU(I2).NE.1) GOTO 262
            IF (IVU(I3).NE.1) GOTO 262
            X1=XPROJ(1,I1)
            X2=XPROJ(1,I2)
            X3=XPROJ(1,I3)
            Y1=XPROJ(2,I1)
            Y2=XPROJ(2,I2)
            Y3=XPROJ(2,I3)
            Z1=0.
            Z2=0.
            Z3=0.
            XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3)
            YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3)
            ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3)
            DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2)
            XNORM=XNORM/DNORM
            YNORM=YNORM/DNORM
            ZNORM=ZNORM/DNORM
            ANG=0.
            I1=ICPR(IPT1.NUM(ISOM(ISOM(/1)),J))
            XV1=XPROJ(1,I1)-XP
            YV1=XPROJ(2,I1)-YP
            ZV1=0.
            DO 263 IS=1,ISOM(/1)
               I2=ICPR(IPT1.NUM(ISOM(IS),J))
               XV2=XPROJ(1,I2)-XP
               YV2=XPROJ(2,I2)-YP
               ZV2=0.
               XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+
     #              ZNORM*(XV1*YV2-YV1*XV2)
               YATA=XV1*XV2+YV1*YV2+ZV1*ZV2
               IF (XATA.EQ.0..AND.YATA.EQ.0.) GOTO 500
               ANG=ANG+ATAN2(XATA,YATA)
               XV1=XV2
               YV1=YV2
               ZV1=ZV2
 263        CONTINUE
            IF (ABS(ANG).GT.XPI) GOTO 500
 262     CONTINUE
         SEGSUP ISOM
 1000    CONTINUE
 220  CONTINUE
* ON N'A PAS TROUVE ON RECOMMENCE
      GOTO 400
* ON A TROUVE ON DESSINE L'ELEMENT EN REDUIT ET EN ROSE
 500  CONTINUE
      IEL=J
      IF (IPT1.EQ.IPPT.AND.IEL.EQ.IEEL) GOTO 650
      IPPT=IPT1
      IEEL=IEL
      XECLAT=0.8
      CALL CHCOUL(1)
      K=IPT1.ITYPEL
      IDEP=LPT(K)
      IFIN=IDEP+2*LPL(K)-2
      IFIN2=IFIN
      IF (LPL(K).EQ.0.AND.LPT(K).NE.0)THEN
C       Polygone
         IFIN =IDEP+2*IPT1.NUM(/1)-2
         IFIN2=IFIN -2
      ENDIF
      I=IEL
      XG=0.
      YG=0.
      N=IPT1.NUM(/1)
      DO 510 J=1,N
         XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I)))
         YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I)))
 510  CONTINUE
      XG=XG/N
      YG=YG/N
      I3=0
      ITR=1
      DO 520 J=IDEP,IFIN,2
         IF (J.LE.IFIN2) THEN
            I1=ICPR(IPT1.NUM(KSEGM(J),I))
            I2=ICPR(IPT1.NUM(KSEGM(J+1),I))
         ELSE
            I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
            I2=ICPR(IPT1.NUM(KSEGM(1),I))
         ENDIF
         XR=XG+(XPROJ(1,I1)-XG)*XECLAT
         YR=YG+(XPROJ(2,I1)-YG)*XECLAT
         IF (I1.NE.I3) THEN
            IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
            ITR=1
            XTR(ITR)=XR
            YTR(ITR)=YR
         ENDIF
         XR=XG+(XPROJ(1,I2)-XG)*XECLAT
         YR=YG+(XPROJ(2,I2)-YG)*XECLAT
         ITR=ITR+1
         XTR(ITR)=XR
         YTR(ITR)=YR
         I3=I2
 520  CONTINUE
      IF (ITR.GT.1)  CALL POLRL(ITR,XTR,YTR,ZTR)
      ITR=1
*  ON MET DANS LE RESULTAT
      ITYP=IPT1.ITYPEL
 630  CONTINUE
      DO 600 IO=1,IPT8.LISOUS(/1)
         IPT2=IPT8.LISOUS(IO)
         IF (ITYP.NE.IPT2.ITYPEL) GOTO 600
         NBNN=IPT2.NUM(/1)
         NBSOUS=0
         NBREF=0
         NBELEM=IPT2.NUM(/2)+1
         SEGADJ IPT2
         DO 610 I=1,NBNN
            IPT2.NUM(I,NBELEM)=IPT1.NUM(I,IEL)
 610     CONTINUE
         IPT2.ICOLOR(NBELEM)=IPT1.ICOLOR(NBELEM)
         GOTO 620
 600  CONTINUE
      NBNN=IPT1.NUM(/1)
      NBELEM=0
      NBREF=0
      NBSOUS=0
      SEGINI IPT2
      IPT2.ITYPEL=IPT1.ITYPEL
      NBNN=0
      NBELEM=0
      NBREF=0
      NBSOUS=IPT8.LISOUS(/1)+1
      SEGADJ IPT8
      IPT8.LISOUS(NBSOUS)=IPT2
      GOTO 630
*  OK ON PEUT CONTINUER
 620  CONTINUE
      GOTO 400
 650  CONTINUE
*  SI UN SEUL SOUS-OBJET ON SIMPLIFIE LA STRUCTURE
      IF (IPT8.LISOUS(/1).EQ.1) THEN
         IPT7=IPT8
         IPT8=IPT7.LISOUS(1)
         SEGSUP IPT7
      ENDIF
      IF (IPT8.NUM(/2).EQ.0) THEN
         SEGSUP IPT8
         RETURN
      ENDIF
*  ON DEMANDE LE NOM
      CALL TRGET('Donnez un nom si necessaire:',ZONE)
      IF (ZONE(1:1).EQ.' ') THEN
         SEGSUP IPT8
         RETURN
      ENDIF
      CALL NOMOBJ('MAILLAGE',ZONE,IPT8)
      RETURN
      END