C FACED     SOURCE    CHAT      07/10/29    21:19:26     5940           
C TRACE D'UN OBJET PAR FACE EN COMMENCANT PAR CELLES DE DERRIERE
C     
C  imod=0 trace en couleur d'effacement
C  imod=1 trace en couleir normale
C
      SUBROUTINE FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,imod)
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC SMELEME
-INC CCGEOME
-INC CCREEL
C+PP DEGRADE OU NON
      LOGICAL lndegr
C+PP  
      SEGMENT XPROJ(3,1)
      SEGMENT ICPR(1)
      SEGMENT IVU(ITE)
      SEGMENT MCOUP(0)
      SEGMENT KON(2,NBCON,NMAX)
      SEGMENT IFAC3(5,NFAC3)
      SEGMENT IFAC4(6,NFAC4)
      SEGMENT IFAC6(8,NFAC6)
      SEGMENT IFAC8(10,NFAC8)
      SEGMENT IFACP(16,NFACP)
      SEGMENT NSOMP(NFACP)
      SEGMENT IFACOL(NFAC)
      SEGMENT TFAC(NFAC)
      SEGMENT KFAK(NFAC)
      SEGMENT NAUX(NFAC)
      DIMENSION XTR(8),YTR(8),ZTR(8),NPTR(8)
      SEGACT MELEME
      MELSAU=MELEME
      IPT1=MELEME
*     IF (MCOUP.NE.0) THEN
*      NBNN=0
*      NBELEM=0
*      NBREF=0
*      NBSOUS=LISOUS(/1)-1
*      SEGINI IPT1
*      DO 5 I=1,NBSOUS
*      IPT1.LISOUS(I)=LISOUS(I)
*   5  CONTINUE
*      ISCOUP=LISOUS(NBSOUS+1)
*     ENDIF
*     call ecmail(ipt1,0)
      CALL ECROBJ('MAILLAGE',IPT1)
      CALL ENVELO
*      IF (MCOUP.NE.0) SEGSUP IPT1
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      IF (IERR.NE.0) RETURN
      SEGACT MELEME
*      IF (MCOUP.NE.0) THEN
*        IF (LISOUS(/1).NE.0) THEN
*         NBSOUS=LISOUS(/1)+1
*         SEGADJ MELEME
*         LISOUS(NBSOUS)=ISCOUP
*        ELSE
*         NBSOUS=2
*         SEGINI IPT1
*         IPT1.LISOUS(1)=MELEME
*         IPT1.LISOUS(2)=ISCOUP
*         MELEME=IPT1
*        ENDIF
*      ENDIF
      SEGACT XPROJ,ICPR
      SEGACT KON*MOD
      NBCON=KON(/2)
      NBCONR=NBCON-1
      NBPOIN=XPROJ(/2)
      TMIN=xsgran
      TMAX=-xsgran
      DO 1 I=1,NBPOIN
         TMIN=MIN(TMIN,XPROJ(3,I))
         TMAX=MAX(TMAX,XPROJ(3,I))
 1    CONTINUE
      TDIST=TMAX-TMIN
      NFAC3=0
      NFAC4=0
      NFAC6=0
      NFAC8=0
      NFACP=0
      IPT1=MELEME
      SEGACT MELEME
      DO 10 IOB=1,MAX(1,LISOUS(/1))
         IF (LISOUS(/1).NE.0) THEN
            IPT1=LISOUS(IOB)
            SEGACT IPT1
         ENDIF
         NBELEM=IPT1.NUM(/2)
         ILTEL=LTEL(1,IPT1.ITYPEL)
         IF (ILTEL.EQ.0) GOTO 12
         ILTAD=LTEL(2,IPT1.ITYPEL)
         DO 13 IF=1,ILTEL
            IFT=LDEL(1,ILTAD+IF-1)
            GOTO (21,22,23,24,25,26),IFT
 21         NFAC3=NFAC3+NBELEM
            GOTO 30
 22         NFAC4=NFAC4+NBELEM
            GOTO 30
 23         NFAC6=NFAC6+NBELEM
            GOTO 30
 24         NFAC8=NFAC8+NBELEM
            GOTO 30
 25         GOTO 30
 26         NFACP=NFACP+NBELEM
            GOTO 30
 30         CONTINUE
 13      CONTINUE
 12      CONTINUE
 10   CONTINUE
      SEGINI IFAC3,IFAC4,IFAC6,IFAC8,IFACP,NSOMP
      NFAC3=0
      NFAC4=0
      NFAC6=0
      NFAC8=0
      NFACP=0
      ICOUPE=0
      DO 50 IOB=1,MAX(1,LISOUS(/1))
         IF (LISOUS(/1).NE.0) THEN
            IPT1=LISOUS(IOB)
            ICOUPE=0
            IF (IOB.EQ.LISOUS(/1).AND.MCOUP.NE.0) ICOUPE=1
         ENDIF
         NBELEM=IPT1.NUM(/2)
         ILTEL=LTEL(1,IPT1.ITYPEL)
         IF (ILTEL.EQ.0) GOTO 52
         ILTAD=LTEL(2,IPT1.ITYPEL)
         DO 60 IF=1,ILTEL
            ITYP=LDEL(1,ILTAD+IF-1)
            IAD=LDEL(2,ILTAD+IF-1)
            DO 70 IEL=1,NBELEM
               GOTO (61,62,63,64,67,66),ITYP
 61            NFAC3=NFAC3+1
               IFAC3(1,NFAC3)=ICPR(IPT1.NUM(LFAC(IAD),IEL))
               IFAC3(2,NFAC3)=ICPR(IPT1.NUM(LFAC(IAD+1),IEL))
               IFAC3(3,NFAC3)=ICPR(IPT1.NUM(LFAC(IAD+2),IEL))
               IFAC3(4,NFAC3)=IPT1.ICOLOR(IEL)
               IFAC3(5,NFAC3)=0
               IF (IVU(IFAC3(1,NFAC3)).EQ.1.AND.IVU(IFAC3(2,NFAC3)).EQ.1
     $              .AND.IVU(IFAC3(3,NFAC3)).EQ.1)    IFAC3(5,NFAC3)=1
               IF (ICOUPE.EQ.1) THEN
                  IF (MCOUP(IEL)/8.EQ.1) IFAC3(5,NFAC3)=2
                  IF (MCOUP(IEL)/16.EQ.1) IFAC3(5,NFAC3)=3
               ENDIF
               GOTO 67
 62            NFAC4=NFAC4+1
               IFAC4(1,NFAC4)=ICPR(IPT1.NUM(LFAC(IAD),IEL))
               IFAC4(2,NFAC4)=ICPR(IPT1.NUM(LFAC(IAD+1),IEL))
               IFAC4(3,NFAC4)=ICPR(IPT1.NUM(LFAC(IAD+2),IEL))
               IFAC4(4,NFAC4)=ICPR(IPT1.NUM(LFAC(IAD+3),IEL))
               IFAC4(5,NFAC4)=IPT1.ICOLOR(IEL)
               IFAC4(6,NFAC4)=0
               IF (IVU(IFAC4(1,NFAC4)).EQ.1.AND.IVU(IFAC4(2,NFAC4)).EQ.1
     $              .AND.IVU(IFAC4(3,NFAC4)).EQ.1.AND.IVU(IFAC4(4,NFAC4)
     $              ).EQ.1)IFAC4(6,NFAC4)=1
               GOTO 67
 63            NFAC6=NFAC6+1
               IFAC6(1,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD)  ,IEL))
               IFAC6(2,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+1),IEL))
               IFAC6(3,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+2),IEL))
               IFAC6(4,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+3),IEL))
               IFAC6(5,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+4),IEL))
               IFAC6(6,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+5),IEL))
               IFAC6(7,NFAC6)=IPT1.ICOLOR(IEL)
               IFAC6(8,NFAC6)=0
               IF (IVU(IFAC6(1,NFAC6)).EQ.1.AND.IVU(IFAC6(2,NFAC6)).EQ.1
     $              .AND.IVU(IFAC6(3,NFAC6)).EQ.1.AND.IVU(IFAC6(4,NFAC6)
     $              ).EQ.1.AND.IVU(IFAC6(5,NFAC6)).EQ.1.AND.IVU(IFAC6(6
     $              ,NFAC6)).EQ.1)IFAC6(8,NFAC6)=1
               GOTO 67
 64            CONTINUE
               NFAC8=NFAC8+1
               IFAC8(1,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD)  ,IEL))
               IFAC8(2,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+1),IEL))
               IFAC8(3,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+2),IEL))
               IFAC8(4,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+3),IEL))
               IFAC8(5,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+4),IEL))
               IFAC8(6,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+5),IEL))
               IFAC8(7,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+6),IEL))
               IFAC8(8,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+7),IEL))
               IFAC8(9,NFAC8)=IPT1.ICOLOR(IEL)
               IFAC8(10,NFAC8)=0
               IF (IVU(IFAC8(1,NFAC8)).EQ.1.AND.IVU(IFAC8(2,NFAC8)).EQ.1
     $              .AND.IVU(IFAC8(3,NFAC8)).EQ.1.AND.IVU(IFAC8(4,NFAC8)
     $              ).EQ.1.AND.IVU(IFAC8(5,NFAC8)).EQ.1.AND.IVU(IFAC8(6
     $              ,NFAC8)).EQ.1.AND.IVU(IFAC8(7,NFAC8)).EQ.1.AND
     $              .IVU(IFAC8(8,NFAC8)).EQ.1)IFAC8(10,NFAC8)=1
               GOTO 67
 66            NFACP=NFACP+1
               IFACP(16,NFACP)=1
               IFACP(15,NFACP)=IPT1.ICOLOR(IEL)
               NBNN=IPT1.NUM(/1)
               NSOMP(NFACP)= NBNN
               DO 660, IDC = 1, NBNN
                  IFACP(IDC,NFACP)=ICPR(IPT1.NUM(LFAC(IAD+IDC-1),IEL))
                  IF (IVU(IFACP(IDC,NFACP)).NE.1) IFACP(16,NFACP)=0
 660           CONTINUE
               GOTO 67
 67            CONTINUE
 70         CONTINUE
 60      CONTINUE
 52      CONTINUE
         IF (LISOUS(/1).NE.0) SEGDES IPT1
 50   CONTINUE
      SEGDES MELEME
C  IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES
C  PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON
      NFAC=NFAC3+NFAC4+NFAC6+NFAC8+NFACP
      SEGINI TFAC,KFAK,IFACOL
      IF (NFAC3.EQ.0) GOTO 101
      DO 102 I=1,NFAC3
         TFAC(I)=(XPROJ(3,IFAC3(1,I))+XPROJ(3,IFAC3(2,I))
     #        +   XPROJ(3,IFAC3(3,I)))/3.
         IF (IFAC3(5,I).EQ.1) TFAC(I)=TFAC(I)-TDIST
         IF (IFAC3(5,I).EQ.2) TFAC(I)=TFAC(I)-2*TDIST
         IFACOL(I)=IFAC3(4,I)
         KFAK(I)=I
         IF (IFAC3(5,I).EQ.3) KFAK(I)=0
 102  CONTINUE
 101  CONTINUE
      IF (NFAC4.EQ.0) GOTO 103
      DO 104 I=1,NFAC4
         TFAC(I+NFAC3)=(XPROJ(3,IFAC4(1,I))+XPROJ(3,IFAC4(2,I))
     #        +   XPROJ(3,IFAC4(3,I))+XPROJ(3,IFAC4(4,I)))/4.
         IF (IFAC4(6,I).EQ.1) TFAC(I+NFAC3)=TFAC(I+NFAC3)-TDIST
         IFACOL(I+NFAC3)=IFAC4(5,I)
         KFAK(I+NFAC3)=I+NFAC
 104  CONTINUE
 103  CONTINUE
      IF (NFAC6.EQ.0) GOTO 105
      DO 106 I=1,NFAC6
         TFAC(I+NFAC3+NFAC4)=(XPROJ(3,IFAC6(1,I))+XPROJ(3,IFAC6(2,I))
     #        +   XPROJ(3,IFAC6(3,I))+XPROJ(3,IFAC6(4,I))
     #        +   XPROJ(3,IFAC6(5,I))+XPROJ(3,IFAC6(6,I)))/6.
         IF (IFAC6(8,I).EQ.1) TFAC(I+NFAC3+NFAC4)=TFAC(I+NFAC3+NFAC4)
     #        -TDIST
         IFACOL(I+NFAC3+NFAC4)=IFAC6(7,I)
         KFAK(I+NFAC3+NFAC4)=I+2*NFAC
 106  CONTINUE
 105  CONTINUE
      IF (NFAC8.EQ.0) GOTO 107
      DO 108 I=1,NFAC8
         TFAC(I+NFAC3+NFAC4+NFAC6)=(XPROJ(3,IFAC8(1,I))
     #        +XPROJ(3,IFAC8(2,I))+XPROJ(3,IFAC8(3,I))+XPROJ(3,IFAC8(4,I
     $        ))+XPROJ(3,IFAC8(5,I))+XPROJ(3,IFAC8(6,I))+XPROJ(3,IFAC8(7
     $        ,I))+XPROJ(3,IFAC8(8,I)))/8.
         IF (IFAC8(10,I).EQ.1) TFAC(I+NFAC3+NFAC4+NFAC6)=
     #        TFAC(I+NFAC3+NFAC4+NFAC6)-TDIST
         IFACOL(I+NFAC3+NFAC4+NFAC6)=IFAC8(9,I)
         KFAK(I+NFAC3+NFAC4+NFAC6)=I+3*NFAC
 108  CONTINUE
 107  CONTINUE
      IF (NFACP.EQ.0) GOTO 110
      DO 109 I=1,NFACP
         XXXX = 0.
         DO 120 J=1, NSOMP(I)
            XXXX = XXXX + XPROJ(3,ICPR(IFACP(J,I)))
 120     CONTINUE
         TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8)= XXXX/NSOMP(I)
         IF (IFACP(16,I).EQ.1) TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8)=
     #        TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8)-TDIST
         IFACOL(I+NFAC3+NFAC4+NFAC6+NFAC8)=IFACP(15,I)
         KFAK(I+NFAC3+NFAC4+NFAC6+NFAC8)=I+4*NFAC
 109  CONTINUE
 110  CONTINUE
C  IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT TFAC
      SEGINI NAUX
      IF (IDIM.EQ.2) GOTO 209
      NAUX(1)=1
      NAUX(2)=NFAC
      IZ=2
 208  IZ=IZ-1
      IF (IZ.LE.0) GOTO 209
      IPB=NAUX(IZ*2-1)
      IPH=NAUX(IZ*2)
      IF(IPB.GE.IPH) GOTO 208
      JPB=IPB-1
      JPH=IPH+1
C  CALCUL DU PIVOT
      PV=0.
*     DO 207 J=IPB,IPH
*     PV=PV+TFAC(J)
*207  CONTINUE
*     PV=PV/(IPH-IPB+1)
      PV=(TFAC(IPB)+TFAC(IPH))/2.
 242  JPB=JPB+1
      IF (JPH.EQ.JPB) GOTO 245
      IF (TFAC(JPB).LT.PV) GOTO 243
      GOTO 242
 243  JPH=JPH-1
      IF (JPH.EQ.JPB) GOTO 245
      IF (TFAC(JPH).GT.PV) GOTO 244
      GOTO 243
 244  IAUX=KFAK(JPB)
      IAUXX=IFACOL(JPB)
      KFAK(JPB)=KFAK(JPH)
      IFACOL(JPB)=IFACOL(JPH)
      KFAK(JPH)=IAUX
      IFACOL(JPH)=IAUXX
      TAUX=TFAC(JPB)
      TFAC(JPB)=TFAC(JPH)
      TFAC(JPH)=TAUX
      GOTO 242
 245  IF (JPB.GE.IPB) GOTO 247
      JPB=JPB+1
      JPH=JPH+2
      GOTO 248
 247  IF (JPH.LE.IPH) GOTO 249
      JPB=JPB-2
      JPH=JPH-1
      GOTO 248
 249  IF (TFAC(JPB).LE.PV) GOTO 250
      IF (JPH.EQ.IPH) GOTO 251
 252  JPH=JPH+1
      GOTO 248
 250  IF (JPB.EQ.IPB) GOTO 252
 251  JPB=JPB-1
 248  IF (JPB.EQ.IPB) GOTO 253
      NAUX(2*IZ)=JPB
      IZ=IZ+1
 253  IF (JPH.EQ.IPH) GOTO 208
      NAUX(2*IZ)=IPH
      NAUX(2*IZ-1)=JPH
      IZ=IZ+1
      GOTO 208
 209  CONTINUE
C  LES FACES SONT CLASSEES DANS KFAK LES FACES ON ETE ELIMINEES PAR
C  ENVELO .   IL NE RESTE PLUS QU'A TRACER
      DO 300 I=1,NFAC
         IFF=KFAK(I)
         IF (IFF.EQ.0) GOTO 300
         IT=(IFF-1)/NFAC
         IF=IFF-IT*NFAC
         IT=IT+1
         IOK=0
         GOTO (310,320,330,340,350),IT
 310     NP=3
         DO 311 IP=1,NP
            XTR(IP)=XPROJ(1,IFAC3(IP,IF))
            YTR(IP)=XPROJ(2,IFAC3(IP,IF))
            ZTR(IP)=XPROJ(3,IFAC3(IP,IF))
            NPTR(IP)=IFAC3(IP,IF)
            IF (IVU(IFAC3(IP,IF)).EQ.1) IOK=1
 311     CONTINUE
         GOTO 370
 320     NP=4
         DO 321 IP=1,NP
            XTR(IP)=XPROJ(1,IFAC4(IP,IF))
            YTR(IP)=XPROJ(2,IFAC4(IP,IF))
            ZTR(IP)=XPROJ(3,IFAC4(IP,IF))
            NPTR(IP)=IFAC4(IP,IF)
            IF (IVU(IFAC4(IP,IF)).EQ.1) IOK=1
 321     CONTINUE
         GOTO 370
 330     NP=6
         DO 331 IP=1,NP
            XTR(IP)=XPROJ(1,IFAC6(IP,IF))
            YTR(IP)=XPROJ(2,IFAC6(IP,IF))
            ZTR(IP)=XPROJ(3,IFAC6(IP,IF))
            NPTR(IP)=IFAC6(IP,IF)
            IF (IVU(IFAC6(IP,IF)).EQ.1) IOK=1
 331     CONTINUE
         GOTO 370
 340     NP=8
         DO 341 IP=1,NP
            XTR(IP)=XPROJ(1,IFAC8(IP,IF))
            YTR(IP)=XPROJ(2,IFAC8(IP,IF))
            ZTR(IP)=XPROJ(3,IFAC8(IP,IF))
            NPTR(IP)=IFAC8(IP,IF)
            IF (IVU(IFAC8(IP,IF)).EQ.1) IOK=1
 341     CONTINUE
         GOTO 370
 350     NP=NSOMP(IF)
         DO 351 IP=1,NP
            XTR(IP)=XPROJ(1,IFACP(IP,IF))
            YTR(IP)=XPROJ(2,IFACP(IP,IF))
            ZTR(IP)=XPROJ(3,IFACP(IP,IF))
            NPTR(IP)=IFACP(IP,IF)
            IF (IVU(IFACP(IP,IF)).EQ.1) IOK=1
 351     CONTINUE
 370     CONTINUE
         IF (IOK.EQ.0) GOTO 300
C  DETERMINATION DE LA COULEUR D'APRES L'ORIENTATION DE LA NORMALE
         XN=0.
         YN=0.
         ZN=0.
         XDE=XTR(NP)
         YDE=YTR(NP)
         ZDE=ZTR(NP)
         XW1=XTR(1)-XDE
         YW1=YTR(1)-YDE
         ZW1=ZTR(1)-ZDE
         DO 900 I2=2,NP-1
            XW2=XTR(I2)-XDE
            YW2=YTR(I2)-YDE
            ZW2=ZTR(I2)-ZDE
            XN=XN+(YW1*ZW2-ZW1*YW2)
            YN=YN+(ZW1*XW2-XW1*ZW2)
            ZN=ZN+(XW1*YW2-YW1*XW2)
            XW1=XW2
            YW1=YW2
            ZW1=ZW2
 900     CONTINUE
         DN=SQRT(XN**2+YN**2+ZN**2)
         IF (DN.EQ.0.) DN=1.
         ZN=ASIN(ABS(ZN/DN))
C+PP DEGRADE OU NON
         IF (lndegr) ZN=REAL(XPI/2.D0)
C+PP  
         IFACO=IFACOL(I)
         if (imod.eq.0) ifaco=8
         CALL TRFACE(NP,XTR,YTR,ZTR,ZN,IFACO,IEFF)
         if (imod.eq.0) ieff=0
C  SI IEFF <> 0 IL FAUT METTRE LES TRAITS EN EFFACEMENT
         N1=NPTR(NP)
         DO 450 IIP=1,NP
            N2=NPTR(IIP)
            NI=N1
            NJ=N2
 459        CONTINUE
 457        DO 454 K=1,NBCONR
               IF (KON(1,K,NI).NE.NJ) GOTO 454
C  8 = EFFACEMENT
               KON(2,K,NI)=8
               IF (IEFF.EQ.0) KON(2,K,NI)=IFACOL(I)
               GOTO 456
 454        CONTINUE
            IF (KON(1,NBCON,NI).EQ.0) GOTO 456
            NI=KON(1,NBCON,NI)
            GOTO 457
 456        CONTINUE
            NI=N2
            NJ=N1
 469        CONTINUE
 467        DO 464 K=1,NBCONR
               IF (KON(1,K,NI).NE.NJ) GOTO 464
C  8 = EFFACEMENT
               KON(2,K,NI)=8
               IF (IEFF.EQ.0) KON(2,K,NI)=IFACOL(I)
               GOTO 466
 464        CONTINUE
            IF (KON(1,NBCON,NI).EQ.0) GOTO 466
            NI=KON(1,NBCON,NI)
            GOTO 467
 466        CONTINUE
            N1=N2
 450     CONTINUE
 300  CONTINUE
C 'EST FINI
      SEGACT MELEME
      IF (LISOUS(/1).NE.0) THEN
         NBSOUS=LISOUS(/1)
*      IF (MCOUP.NE.0) NBSOUS=NBSOUS-1
         DO 490 IO=1,NBSOUS
            IPT2=LISOUS(IO)
            segact ipt2
            if (ipt2.itypel.gt.3.AND.ipt2.itypel.NE.32) SEGSUP IPT2
 490     CONTINUE
      ENDIF
      if (itypel.eq.0) SEGSUP MELEME
      MELEME=MELSAU
      SEGDES KON
      SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NAUX,TFAC,KFAK,IFACOL,IFACP,NSOMP
      RETURN
      END