C FACED2    SOURCE    PV        12/04/13    21:15:20     7351           
C TRACE D'ISOVALEUR EN COMMENCANT PAR CELLES DE DERRIERE
C
      SUBROUTINE FACED2(MELEME,XPROJ,ICPR,VCHC,VCPCHA,PTI,NISO,IVU,
     # MCOUP,mcham)
*  si mchaml est non nul on trace un chamelem aux noeuds
*  sinon c'est un champoint
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC SMELEME
-INC CCGEOME
-INC SMCHAML
      DIMENSION XX(13),YY(13),ZZ(13),VV(13)
      SEGMENT XPROJ(3,1)
      SEGMENT ICPR(1)
      SEGMENT VCPCHA(XCOOR(/1)/(IDIM+1))
      SEGMENT ISEG2(2,NSEG2)
      SEGMENT ISEG3(3,NSEG3)
      SEGMENT IFAC3(4,NFAC3)
      SEGMENT IFAC4(5,NFAC4)
      SEGMENT IFAC6(7,NFAC6)
      SEGMENT IFAC8(9,NFAC8)
      SEGMENT IFACP(15,NFACP)
      SEGMENT XSEG2(2,NSEG2)
      SEGMENT XSEG3(3,NSEG3)
      SEGMENT XFAC3(3,NFAC3)
      SEGMENT XFAC4(4,NFAC4)
      SEGMENT XFAC6(6,NFAC6)
      SEGMENT XFAC8(8,NFAC8)
      SEGMENT XFACP(14,NFACP)
      SEGMENT NSOMP(NFACP)
      SEGMENT TFAC(NFAC)
      SEGMENT KFAK(NFAC)
      SEGMENT NAUX(max(2,NFAC))
      SEGMENT IVU(0)
      SEGMENT MCOUP(0)
      DIMENSION XTR(8),YTR(8),ZTR(8)
      REAL VCHC
      DIMENSION VCHC(*)

      SEGACT MELEME
*     ipt1=lisous(1)
*     segact ipt1
*     SEGACT XPROJ,ICPR
      MELSAU=MELEME
      IPT1=MELEME
      melval=ipt1 
*     write (6,*) ' faced2 velche '
*     write (6,*)  (velche(ix,1),ix=1,20)
      if (mcham.eq.0) then
        CALL ECROBJ('MAILLAGE',IPT1)
        CALL ENVELO
        CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      else
        CALL ENVEL1(ipt1,meleme)
      endif
      IF (IERR.NE.0) RETURN

      SEGACT MELEME
      SEGACT XPROJ,ICPR
      NBPOIN=XPROJ(/2)
      TMIN=1E30
      TMAX=-1E30
      DO 1 I=1,NBPOIN
      TMIN=MIN(TMIN,XPROJ(3,I))
      TMAX=MAX(TMAX,XPROJ(3,I))
   1  CONTINUE
      TDIST=TMAX-TMIN
      NSEG2=0
      NSEG3=0
      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 27
  22  NFAC4=NFAC4+NBELEM
      GOTO 27
  23  NFAC6=NFAC6+NBELEM
      GOTO 27
  24  NFAC8=NFAC8+NBELEM
      GOTO 27
  25  GOTO 27
  26  NFACP=NFACP+NBELEM
      GOTO 27
  27  CONTINUE
  13  CONTINUE
      goto 10
  12  CONTINUE
      if (ipt1.itypel.eq.2) nseg2=nseg2+nbelem
      if (ipt1.itypel.eq.3) nseg3=nseg3+nbelem
  10  CONTINUE
      SEGINI iseg2,iseg3,IFAC3,IFAC4,IFAC6,IFAC8,IFACP,NSOMP
      if (mcham.ne.0) SEGINI xseg2,xseg3,xFAC3,xFAC4,xFAC6,xFAC8,xFACP
      NSEG2=0
      NSEG3=0
      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)
       ivm1=0
       ivm2=0
       melval=meleme
       if (mcham.ne.0) then
          melval=lisref(iob)
          ivm1=velche(/1)
          ivm2=velche(/2)
          if (ivm1*ivm2.eq.0) return
       endif
       ICOUPE=0
       IF (IOB.EQ.LISOUS(/1).AND.MCOUP.NE.0) ICOUPE=1
      ENDIF
      NBELEM=IPT1.NUM(/2)
      NBNN  =IPT1.NUM(/1)
      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 80 IEL=1,NBELEM
       do 70 inn=1,nbnn
        if (icpr(ipt1.num(inn,iel)).eq.0) then
         call erreur(23)
         goto  80
        endif
  70   continue
      GOTO (61,62,63,64,67,66),ITYP
  61  NFAC3=NFAC3+1
      IFAC3(1,NFAC3)=IPT1.NUM(LFAC(IAD),IEL)
      IFAC3(2,NFAC3)=IPT1.NUM(LFAC(IAD+1),IEL)
      IFAC3(3,NFAC3)=IPT1.NUM(LFAC(IAD+2),IEL)
      if (mcham.ne.0) then
       xFAC3(1,NFAC3)=velche(min(ivm1,LFAC(IAD)),min(ivm2,IEL))
       xFAC3(2,NFAC3)=velche(min(ivm1,LFAC(IAD+1)),min(ivm2,IEL))
       xFAC3(3,NFAC3)=velche(min(ivm1,LFAC(IAD+2)),min(ivm2,IEL))
      endif
       IFAC3(4,NFAC3)=0
      IF (IVU(ICPR(IFAC3(1,NFAC3))).EQ.1.AND.
     # IVU(ICPR(IFAC3(2,NFAC3))).EQ.1.AND.
     # IVU(ICPR(IFAC3(3,NFAC3))).EQ.1)    IFAC3(4,NFAC3)=1
      IF (ICOUPE.EQ.1) THEN
        IF (MCOUP(IEL)/8.EQ.1) IFAC3(4,NFAC3)=2
        IF (MCOUP(IEL)/16.EQ.1) IFAC3(4,NFAC3)=3
      ENDIF
      GOTO 67
  62  NFAC4=NFAC4+1
      IFAC4(1,NFAC4)=IPT1.NUM(LFAC(IAD),IEL)
      IFAC4(2,NFAC4)=IPT1.NUM(LFAC(IAD+1),IEL)
      IFAC4(3,NFAC4)=IPT1.NUM(LFAC(IAD+2),IEL)
      IFAC4(4,NFAC4)=IPT1.NUM(LFAC(IAD+3),IEL)
      if (mcham.ne.0) then
       xFAC4(1,NFAC4)=velche(min(ivm1,LFAC(IAD)),min(ivm2,IEL))
       xFAC4(2,NFAC4)=velche(min(ivm1,LFAC(IAD+1)),min(ivm2,IEL))
       xFAC4(3,NFAC4)=velche(min(ivm1,LFAC(IAD+2)),min(ivm2,IEL))
       xFAC4(4,NFAC4)=velche(min(ivm1,LFAC(IAD+3)),min(ivm2,IEL))
      endif
       IFAC4(5,NFAC4)=0
      IF (IVU(ICPR(IFAC4(1,NFAC4))).EQ.1.AND.
     # IVU(ICPR(IFAC4(2,NFAC4))).EQ.1.AND.
     # IVU(ICPR(IFAC4(3,NFAC4))).EQ.1.AND.
     # IVU(ICPR(IFAC4(4,NFAC4))).EQ.1)
     #  IFAC4(5,NFAC4)=1
      GOTO 67
  63  NFAC6=NFAC6+1
      IFAC6(1,NFAC6)=IPT1.NUM(LFAC(IAD)  ,IEL)
      IFAC6(2,NFAC6)=IPT1.NUM(LFAC(IAD+1),IEL)
      IFAC6(3,NFAC6)=IPT1.NUM(LFAC(IAD+2),IEL)
      IFAC6(4,NFAC6)=IPT1.NUM(LFAC(IAD+3),IEL)
      IFAC6(5,NFAC6)=IPT1.NUM(LFAC(IAD+4),IEL)
      IFAC6(6,NFAC6)=IPT1.NUM(LFAC(IAD+5),IEL)
      if (mcham.ne.0) then
       xFAC6(1,NFAC6)=velche(min(ivm1,LFAC(IAD))  ,min(ivm2,IEL))
       xFAC6(2,NFAC6)=velche(min(ivm1,LFAC(IAD+1)),min(ivm2,IEL))
       xFAC6(3,NFAC6)=velche(min(ivm1,LFAC(IAD+2)),min(ivm2,IEL))
       xFAC6(4,NFAC6)=velche(min(ivm1,LFAC(IAD+3)),min(ivm2,IEL))
       xFAC6(5,NFAC6)=velche(min(ivm1,LFAC(IAD+4)),min(ivm2,IEL))
       xFAC6(6,NFAC6)=velche(min(ivm1,LFAC(IAD+5)),min(ivm2,IEL))
      endif
       IFAC6(7,NFAC6)=0
           ipa=icpr(ifac6(1,nfac6))
           ipb=icpr(ifac6(2,nfac6))
           ipc=icpr(ifac6(3,nfac6))
           ipd=icpr(ifac6(4,nfac6))
           ipe=icpr(ifac6(5,nfac6))
           ipf=icpr(ifac6(6,nfac6))
      IF (IVU(ipa).EQ.1.AND.IVU(ipb).EQ.1.AND.IVU(ipc).EQ.1
     >   .AND.IVU(ipd).EQ.1.AND.IVU(ipe).EQ.1
     >   .AND.IVU(ipf).EQ.1)
     >    IFAC6(7,NFAC6)=1
      GOTO 67
  64  CONTINUE
      NFAC8=NFAC8+1
      IFAC8(1,NFAC8)=IPT1.NUM(LFAC(IAD)  ,IEL)
      IFAC8(2,NFAC8)=IPT1.NUM(LFAC(IAD+1),IEL)
      IFAC8(3,NFAC8)=IPT1.NUM(LFAC(IAD+2),IEL)
      IFAC8(4,NFAC8)=IPT1.NUM(LFAC(IAD+3),IEL)
      IFAC8(5,NFAC8)=IPT1.NUM(LFAC(IAD+4),IEL)
      IFAC8(6,NFAC8)=IPT1.NUM(LFAC(IAD+5),IEL)
      IFAC8(7,NFAC8)=IPT1.NUM(LFAC(IAD+6),IEL)
      IFAC8(8,NFAC8)=IPT1.NUM(LFAC(IAD+7),IEL)
      if (mcham.ne.0) then
       xFAC8(1,NFAC8)=velche(min(ivm1,LFAC(IAD))  ,min(ivm2,IEL))
       xFAC8(2,NFAC8)=velche(min(ivm1,LFAC(IAD+1)),min(ivm2,IEL))
       xFAC8(3,NFAC8)=velche(min(ivm1,LFAC(IAD+2)),min(ivm2,IEL))
       xFAC8(4,NFAC8)=velche(min(ivm1,LFAC(IAD+3)),min(ivm2,IEL))
       xFAC8(5,NFAC8)=velche(min(ivm1,LFAC(IAD+4)),min(ivm2,IEL))
       xFAC8(6,NFAC8)=velche(min(ivm1,LFAC(IAD+5)),min(ivm2,IEL))
       xFAC8(7,NFAC8)=velche(min(ivm1,LFAC(IAD+6)),min(ivm2,IEL))
       xFAC8(8,NFAC8)=velche(min(ivm1,LFAC(IAD+7)),min(ivm2,IEL))
      endif
       IFAC8(9,NFAC8)=0
           ipa=icpr(ifac8(1,nfac8))
           ipb=icpr(ifac8(2,nfac8))
           ipc=icpr(ifac8(3,nfac8))
           ipd=icpr(ifac8(4,nfac8))
           ipe=icpr(ifac8(5,nfac8))
           ipf=icpr(ifac8(6,nfac8))
           ipg=icpr(ifac8(7,nfac8))
           iph=icpr(ifac8(8,nfac8))
      IF (IVU(ipa).EQ.1.AND.IVU(ipb).EQ.1.AND.IVU(ipc).EQ.1
     >   .AND.IVU(ipd).EQ.1.AND.IVU(ipe).EQ.1
     >   .AND.IVU(ipf).EQ.1.AND.IVU(ipg).EQ.1
     >   .AND.IVU(iph).EQ.1)
     >    IFAC8(9,NFAC8)=1
      GOTO 67
  66  NFACP=NFACP+1
      IFACP(15,NFACP)=1
      NSOMP(NFACP)= NBNN
      DO 660, IDC = 1, NBNN
        IFACP(IDC,NFACP)=IPT1.NUM(LFAC(IAD+IDC-1),IEL)
        if (mcham.ne.0) then
          XFACP(IDC,NFACP)=velche(min(ivm1,LFAC(IAD+IDC-1)),
     >           min(ivm2,IEL))
        endif
        IF (IVU(ICPR(IFACP(IDC,NFACP))).NE.1) IFACP(15,NFACP)=0
 660  CONTINUE
      GOTO 67
  67  CONTINUE
  80  CONTINUE
  60  CONTINUE
      IF (LISOUS(/1).NE.0) SEGDES IPT1
      goto 50
  52  CONTINUE
      do 68 iel=1,nbelem
        if (ipt1.itypel.eq.2) then
          nseg2=nseg2+1
          ISEG2(1,NSEG2)=IPT1.NUM(1,IEL)
          ISEG2(2,NSEG2)=IPT1.NUM(2,IEL)
        elseif (ipt1.itypel.eq.3) then
          nseg3=nseg3+1
          ISEG3(1,NSEG3)=IPT1.NUM(1,IEL)
          ISEG3(2,NSEG3)=IPT1.NUM(2,IEL)
          ISEG3(3,NSEG3)=IPT1.NUM(3,IEL)
        endif
        if (mcham.ne.0) then
          if (ipt1.itypel.eq.2) then
            xSEG2(1,NSEG2)=velche(min(ivm1,1),min(ivm2,IEL))
            xSEG2(2,NSEG2)=velche(min(ivm1,2),min(ivm2,IEL))
          elseif (ipt1.itypel.eq.3) then
            xSEG3(1,NSEG3)=velche(min(ivm1,1),min(ivm2,IEL))
            xSEG3(2,NSEG3)=velche(min(ivm1,2),min(ivm2,IEL))
            xSEG3(3,NSEG3)=velche(min(ivm1,3),min(ivm2,IEL))
          endif
        endif
  68  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=NSEG2+NSEG3+NFAC3+NFAC4+NFAC6+NFAC8+NFACP
      SEGINI TFAC,KFAK
      IF (NFAC3.EQ.0) GOTO 101
      DO 102 I=1,NFAC3
      TFAC(I)=(XPROJ(3,ICPR(IFAC3(1,I)))+XPROJ(3,ICPR(IFAC3(2,I)))
     #     +   XPROJ(3,ICPR(IFAC3(3,I))))/3.
      IF (IFAC3(4,I).EQ.1) TFAC(I)=TFAC(I)-TDIST
      IF (IFAC3(4,I).EQ.2) TFAC(I)=TFAC(I)-2*TDIST
      KFAK(I)=I
      IF (IFAC3(4,I).EQ.3) KFAK(I)=0
 102  CONTINUE
 101  CONTINUE
      IF (NFAC4.EQ.0) GOTO 103
      DO 104 I=1,NFAC4
           ipa=icpr(ifac4(1,i))
           ipb=icpr(ifac4(2,i))
           ipc=icpr(ifac4(3,i))
           ipd=icpr(ifac4(4,i))
      TFAC(I+NFAC3)=(XPROJ(3,ipa)+xproj(3,ipb)+
     > xproj(3,ipc)+xproj(3,ipd))/4.D0
      IF (IFAC4(5,I).EQ.1) TFAC(I+NFAC3)=TFAC(I+NFAC3)-TDIST
      KFAK(I+NFAC3)=I+NFAC
 104  CONTINUE
 103  CONTINUE
      IF (NFAC6.EQ.0) GOTO 105
      DO 106 I=1,NFAC6
           ipa=icpr(ifac6(1,i))
           ipb=icpr(ifac6(2,i))
           ipc=icpr(ifac6(3,i))
           ipd=icpr(ifac6(4,i))
           ipe=icpr(ifac6(5,i))
           ipf=icpr(ifac6(6,i))
      TFAC(I+NFAC3+NFAC4)=(XPROJ(3,ipa)+xproj(3,ipb)+
     > xproj(3,ipc)+xproj(3,ipd)+xproj(3,ipe)+xproj(3,ipf)
     > )/6.D0
      IF (IFAC6(7,I).EQ.1) TFAC(I+NFAC3+NFAC4)=TFAC(I+NFAC3+NFAC4)
     #  -TDIST
      KFAK(I+NFAC3+NFAC4)=I+2*NFAC
 106  CONTINUE
 105  CONTINUE
      IF (NFAC8.EQ.0) GOTO 107
      DO 108 I=1,NFAC8
           ipa=icpr(ifac8(1,i))
           ipb=icpr(ifac8(2,i))
           ipc=icpr(ifac8(3,i))
           ipd=icpr(ifac8(4,i))
           ipe=icpr(ifac8(5,i))
           ipf=icpr(ifac8(6,i))
           ipg=icpr(ifac8(7,i))
           iph=icpr(ifac8(8,i))
      TFAC(I+NFAC3+NFAC4+NFAC6)=(XPROJ(3,ipa)+xproj(3,ipb)+
     > xproj(3,ipc)+xproj(3,ipd)+xproj(3,ipe)+xproj(3,ipf)+
     > xproj(3,ipg)+xproj(3,iph))/8.D0
      IF (IFAC8(9,I).EQ.1) TFAC(I+NFAC3+NFAC4+NFAC6)=
     #   TFAC(I+NFAC3+NFAC4+NFAC6)-TDIST
      KFAK(I+NFAC3+NFAC4+NFAC6)=I+3*NFAC
 108  CONTINUE
 107  CONTINUE
      IF (NSEG2.EQ.0) GOTO 109
      DO 110 I=1,NSEG2
      TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8)=(XPROJ(3,ICPR(ISEG2(1,I)))+
     # XPROJ(3,ICPR(ISEG2(2,I))))/2.
      KFAK(I+NFAC3+NFAC4+NFAC6+NFAC8)=I+4*NFAC
 110  CONTINUE
 109  CONTINUE
      IF (NSEG3.EQ.0) GOTO 111
      DO 112 I=1,NSEG3
      TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8+NSEG2)=(XPROJ(3,ICPR(ISEG3(1,I)))+
     # XPROJ(3,ICPR(ISEG3(2,I)))+XPROJ(3,ICPR(ISEG3(3,I))))/2.
      KFAK(I+NFAC3+NFAC4+NFAC6+NFAC8+NSEG2)=I+5*NFAC
 112  CONTINUE
 111  CONTINUE
      IF (NFACP.EQ.0) GOTO 121
      DO 122 I=1,NFACP
        XXXX = 0.
        DO 123 J=1, NSOMP(I)
          XXXX = XXXX + XPROJ(3,ICPR(IFACP(J,I)))
 123    CONTINUE   
        TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8+NSEG2+NSEG3)= XXXX/NSOMP(I)
        KFAK(I+NFAC3+NFAC4+NFAC6+NFAC8+NSEG2+NSEG3)=I+6*NFAC
 122  CONTINUE
 121  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)
      KFAK(JPB)=KFAK(JPH)
      KFAK(JPH)=IAUX
      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 IL AURAIT FALLU ELIMINER LES FACES
C  EN DOUBLE .   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,360,370),IT
 310  CONTINUE
      IOK=0
      IPA=ICPR(IFAC3(1,IF))
      IF (IVU(IPA).EQ.1) IOK=1
      XX(1)=XPROJ(1,IPA)
      YY(1)=XPROJ(2,IPA)
      ZZ(1)=XPROJ(3,IPA)
      if (mcham.eq.0) then
       VV(1)=VCPCHA(IFAC3(1,IF))
      else
       VV(1)=xFAC3(1,IF)
      endif
      IPB=ICPR(IFAC3(2,IF))
      IF (IVU(IPB).EQ.1) IOK=1
      XX(2)=XPROJ(1,IPB)
      YY(2)=XPROJ(2,IPB)
      ZZ(2)=XPROJ(3,IPB)
      if (mcham.eq.0) then
       VV(2)=VCPCHA(IFAC3(2,IF))
      else
       VV(2)=xFAC3(2,IF)
      endif
      IPC=ICPR(IFAC3(3,IF))
      IF (IVU(IPC).EQ.1) IOK=1
      XX(3)=XPROJ(1,IPC)
      YY(3)=XPROJ(2,IPC)
      ZZ(3)=XPROJ(3,IPC)
      if (mcham.eq.0) then
       VV(3)=VCPCHA(IFAC3(3,IF))
      else
       VV(3)=xFAC3(3,IF)
      endif
      IF (IOK.EQ.1) CALL TRISO(VCHC,XX,YY,ZZ,VV,3,NISO)
      GOTO 380
 320  continue
*  cas des quadrangles on rajoute un point au milieu
           ia=icpr(ifac4(1,if))
           ib=icpr(ifac4(2,if))
           ic=icpr(ifac4(3,if))
           id=icpr(ifac4(4,if))
       IF (IVU(IA).NE.1.AND.IVU(IB).NE.1.AND.IVU(IC).NE.1.AND.
     * IVU(Id).NE.1) goto 380
       xxm=(XPROJ(1,IA)+XPROJ(1,IB)+XPROJ(1,IC)+XPROJ(1,ID))/4.
       yym=(XPROJ(2,IA)+XPROJ(2,IB)+XPROJ(2,IC)+XPROJ(2,ID))/4.
       zzm=(XPROJ(3,IA)+XPROJ(3,IB)+XPROJ(3,IC)+XPROJ(3,ID))/4.
      if (mcham.eq.0) then
       vvm=(VCPCHA(ifac4(1,if))+VCPCHA(ifac4(2,if))+
     *     VCPCHA(ifac4(3,if))+VCPCHA(ifac4(4,if)))/4.
      else
       vvm=(xfac4(1,if)+xfac4(2,if)+
     *     xfac4(3,if)+xfac4(4,if))/4.
      endif
               xx(1)=xxm
               yy(1)=yym
               zz(1)=zzm
               VV(1)=vvm
               xx(2)=xproj(1,ia)
               yy(2)=xproj(2,ia)
               zz(2)=xproj(3,ia)
               xx(3)=xproj(1,ib)
               yy(3)=xproj(2,ib)
               zz(3)=xproj(3,ib)
               xx(4)=xproj(1,ic)
               yy(4)=xproj(2,ic)
               zz(4)=xproj(3,ic)
               xx(5)=xproj(1,id)
               yy(5)=xproj(2,id)
               zz(5)=xproj(3,id)
      if (mcham.eq.0) then
                VV(2)=VCPCHA(ifac4(1,if))
                VV(3)=VCPCHA(ifac4(2,if))
                VV(4)=VCPCHA(ifac4(3,if))
                VV(5)=VCPCHA(ifac4(4,if))
      else
                VV(2)=xfac4(1,if)
                VV(3)=xfac4(2,if)
                VV(4)=xfac4(3,if)
                VV(5)=xfac4(4,if)
      endif
               CALL TCISO(VCHC,XX,YY,ZZ,VV,5,NISO)
               goto 380

 330  continue
*  cas des triangles a 6 noeuds on
           ipa=icpr(ifac6(1,if))
           ipb=icpr(ifac6(2,if))
           ipc=icpr(ifac6(3,if))
           ipd=icpr(ifac6(4,if))
           ipe=icpr(ifac6(5,if))
           ipf=icpr(ifac6(6,if))
       IF (IVU(IpA).NE.1.AND.IVU(IpB).NE.1.AND.IVU(IpC).NE.1.AND.
     *     IVU(IpD).NE.1.AND.IVU(IpE).NE.1.AND.IVU(IpF).NE.1) goto 380
*  cas du quadrangle on rajoute un point central
      xxm=(XPROJ(1,IpB)+XPROJ(1,IpD)+XPROJ(1,IpF))/3
      yym=(XPROJ(2,IpB)+XPROJ(2,IpD)+XPROJ(2,IpF))/3
      zzm=(XPROJ(3,IpB)+XPROJ(3,IpD)+XPROJ(3,IpF))/3
      if (mcham.eq.0) then
      vvm=(VCPCHA(ifac6(2,if))+VCPCHA(ifac6(4,if))+
     >     VCPCHA(ifac6(6,if)))/3
      else
      vvm=(xfac6(2,if)+xfac6(4,if)+xfac6(6,if))/3
      endif
*
               xx(1)=xxm
               yy(1)=yym
               zz(1)=zzm
               VV(1)=vvm
               xx(2)=xproj(1,ipa)
               yy(2)=xproj(2,ipa)
               zz(2)=xproj(3,ipa)
               xx(3)=xproj(1,ipb)
               yy(3)=xproj(2,ipb)
               zz(3)=xproj(3,ipb)
               xx(4)=xproj(1,ipc)
               yy(4)=xproj(2,ipc)
               zz(4)=xproj(3,ipc)
               xx(5)=xproj(1,ipd)
               yy(5)=xproj(2,ipd)
               zz(5)=xproj(3,ipd)
               xx(6)=xproj(1,ipe)
               yy(6)=xproj(2,ipe)
               zz(6)=xproj(3,ipe)
               xx(7)=xproj(1,ipf)
               yy(7)=xproj(2,ipf)
               zz(7)=xproj(3,ipf)
      if (mcham.eq.0) then
                VV(2)=VCPCHA(ifac6(1,if))
                VV(3)=VCPCHA(ifac6(2,if))
                VV(4)=VCPCHA(ifac6(3,if))
                VV(5)=VCPCHA(ifac6(4,if))
                VV(6)=VCPCHA(ifac6(5,if))
                VV(7)=VCPCHA(ifac6(6,if))
      else
                VV(2)=xfac6(1,if)
                VV(3)=xfac6(2,if)
                VV(4)=xfac6(3,if)
                VV(5)=xfac6(4,if)
                VV(6)=xfac6(5,if)
                VV(7)=xfac6(6,if)
      endif
               CALL TCISO(VCHC,XX,YY,ZZ,VV,7,NISO)
               goto 380
 340  continue
*  cas des quadrangles a 8 noeuds
           ipa=icpr(ifac8(1,if))
           ipb=icpr(ifac8(2,if))
           ipc=icpr(ifac8(3,if))
           ipd=icpr(ifac8(4,if))
           ipe=icpr(ifac8(5,if))
           ipf=icpr(ifac8(6,if))
           ipg=icpr(ifac8(7,if))
           iph=icpr(ifac8(8,if))
       IF (IVU(IpA).NE.1.AND.IVU(IpB).NE.1.AND.IVU(IpC).NE.1.AND.
     *     IVU(IpD).NE.1.AND.IVU(IpE).NE.1.AND.IVU(IpF).NE.1.AND.
     >     IVU(IpG).NE.1.AND.IVU(IpH).NE.1) goto 380
*  cas du quadrangle on rajoute un point central
      xxm=-0.25*XPROJ(1,IpA)+0.5*XPROJ(1,IpB)
     *    -0.25*XPROJ(1,IpC)+0.5*XPROJ(1,IpD)
     *    -0.25*XPROJ(1,IpE)+0.5*XPROJ(1,IpF)
     *    -0.25*XPROJ(1,IpG)+0.5*XPROJ(1,IpH)
      yym=-0.25*XPROJ(2,IpA)+0.5*XPROJ(2,IpB)
     *    -0.25*XPROJ(2,IpC)+0.5*XPROJ(2,IpD)
     *    -0.25*XPROJ(2,IpE)+0.5*XPROJ(2,IpF)
     *    -0.25*XPROJ(2,IpG)+0.5*XPROJ(2,IpH)
      zzm=-0.25*XPROJ(3,IpA)+0.5*XPROJ(3,IpB)
     *    -0.25*XPROJ(3,IpC)+0.5*XPROJ(3,IpD)
     *    -0.25*XPROJ(3,IpE)+0.5*XPROJ(3,IpF)
     *    -0.25*XPROJ(3,IpG)+0.5*XPROJ(3,IpH)
      if (mcham.eq.0) then
      vvm=
     * -0.25*VCPCHA(ifac8(1,if))+0.5*VCPCHA(ifac8(2,if))
     * -0.25*VCPCHA(ifac8(3,if))+0.5*VCPCHA(ifac8(4,if))
      vvm = vvm
     * -0.25*VCPCHA(ifac8(5,if))+0.5*VCPCHA(ifac8(6,if))
     * -0.25*VCPCHA(ifac8(7,if))+0.5*VCPCHA(ifac8(8,if))
      else
      vvm=
     * -0.25*xfac8(1,if)+0.5*xfac8(2,if)
     * -0.25*xfac8(3,if)+0.5*xfac8(4,if)
     * -0.25*xfac8(5,if)+0.5*xfac8(6,if)
     * -0.25*xfac8(7,if)+0.5*xfac8(8,if)
      endif
*
               xx(1)=xxm
               yy(1)=yym
               zz(1)=zzm
               VV(1)=vvm
               xx(2)=xproj(1,ipa)
               yy(2)=xproj(2,ipa)
               zz(2)=xproj(3,ipa)
               xx(3)=xproj(1,ipb)
               yy(3)=xproj(2,ipb)
               zz(3)=xproj(3,ipb)
               xx(4)=xproj(1,ipc)
               yy(4)=xproj(2,ipc)
               zz(4)=xproj(3,ipc)
               xx(5)=xproj(1,ipd)
               yy(5)=xproj(2,ipd)
               zz(5)=xproj(3,ipd)
               xx(6)=xproj(1,ipe)
               yy(6)=xproj(2,ipe)
               zz(6)=xproj(3,ipe)
               xx(7)=xproj(1,ipf)
               yy(7)=xproj(2,ipf)
               zz(7)=xproj(3,ipf)
               xx(8)=xproj(1,ipg)
               yy(8)=xproj(2,ipg)
               zz(8)=xproj(3,ipg)
               xx(9)=xproj(1,iph)
               yy(9)=xproj(2,iph)
               zz(9)=xproj(3,iph)
      if (mcham.eq.0) then
                VV(2)=VCPCHA(ifac8(1,if))
                VV(3)=VCPCHA(ifac8(2,if))
                VV(4)=VCPCHA(ifac8(3,if))
                VV(5)=VCPCHA(ifac8(4,if))
                VV(6)=VCPCHA(ifac8(5,if))
                VV(7)=VCPCHA(ifac8(6,if))
                VV(8)=VCPCHA(ifac8(7,if))
                VV(9)=VCPCHA(ifac8(8,if))
      else
                VV(2)=xfac8(1,if)
                VV(3)=xfac8(2,if)
                VV(4)=xfac8(3,if)
                VV(5)=xfac8(4,if)
                VV(6)=xfac8(5,if)
                VV(7)=xfac8(6,if)
                VV(8)=xfac8(7,if)
                VV(9)=xfac8(8,if)
      endif
               CALL TCISO(VCHC,XX,YY,ZZ,VV,9,NISO)
               goto 380
 350  CONTINUE
*  cas du seg2
      IOK=0
      IPA=ICPR(ISEG2(1,IF))
      IF (IVU(IPA).EQ.1) IOK=1
      XX(1)=XPROJ(1,IPA)
      YY(1)=XPROJ(2,IPA)
      ZZ(1)=XPROJ(3,IPA)
      if (mcham.eq.0) then
       VV(1)=VCPCHA(ISEG2(1,IF))
      else
       VV(1)=xseg2(1,IF)
      endif
      IPB=ICPR(Iseg2(2,IF))
      IF (IVU(IPB).EQ.1) IOK=1
      XX(2)=XPROJ(1,IPB)
      YY(2)=XPROJ(2,IPB)
      ZZ(2)=XPROJ(3,IPB)
      if (mcham.eq.0) then
       VV(2)=VCPCHA(Iseg2(2,IF))
      else
       VV(2)=xseg2(2,IF)
      endif
      IF (IOK.EQ.1) CALL TRISO(VCHC,XX,YY,ZZ,VV,2,NISO)
      GOTO 380
 360  CONTINUE
*  cas du seg3
      IOK=0
      IPA=ICPR(ISEG3(1,IF))
      IF (IVU(IPA).EQ.1) IOK=1
      XX(1)=XPROJ(1,IPA)
      YY(1)=XPROJ(2,IPA)
      ZZ(1)=XPROJ(3,IPA)
      if (mcham.eq.0) then
       VV(1)=VCPCHA(ISEG3(1,IF))
      else
       VV(1)=xseg3(1,IF)
      endif
      IPB=ICPR(Iseg3(2,IF))
      IF (IVU(IPB).EQ.1) IOK=1
      XX(2)=XPROJ(1,IPB)
      YY(2)=XPROJ(2,IPB)
      ZZ(2)=XPROJ(3,IPB)
      if (mcham.eq.0) then
       VV(2)=VCPCHA(Iseg3(2,IF))
      else
       VV(2)=xseg3(2,IF)
      endif
      IF (IOK.EQ.1) CALL TRISO(VCHC,XX,YY,ZZ,VV,2,NISO)
      IOK=0
      IPA=ICPR(ISEG3(2,IF))
      IF (IVU(IPA).EQ.1) IOK=1
      XX(1)=XPROJ(1,IPA)
      YY(1)=XPROJ(2,IPA)
      ZZ(1)=XPROJ(3,IPA)
      if (mcham.eq.0) then
       VV(1)=VCPCHA(ISEG3(2,IF))
      else
       VV(1)=xseg3(2,IF)
      endif
      IPB=ICPR(Iseg3(3,IF))
      IF (IVU(IPB).EQ.1) IOK=1
      XX(2)=XPROJ(1,IPB)
      YY(2)=XPROJ(2,IPB)
      ZZ(2)=XPROJ(3,IPB)
      if (mcham.eq.0) then
       VV(2)=VCPCHA(Iseg3(3,IF))
      else
       VV(2)=xseg3(3,IF)
      endif
      IF (IOK.EQ.1) CALL TRISO(VCHC,XX,YY,ZZ,VV,2,NISO)
      GOTO 380
 370  CONTINUE
*
*       POLYGONE
*
        IOK=1
        NBCOT = NSOMP(IF)
*
*          Recherche des coordonnees et valeurs au centre du polygone
*
        XXM = 0.
        YYM = 0.
        VVM = 0.
        IVUE = 1
        DO 3700 ICT = 1, NBCOT
*
          NUPT = IFACP(ICT, IF)
          IDPT = ICPR(NUPT)
          XXM = XPROJ(1,IDPT) + XXM
          YYM = XPROJ(2,IDPT) + YYM
          IF (MCHAM.EQ.0) THEN
            VVM = VCPCHA(NUPT) + VVM
          ELSE
            VVM = XFACP(ICT, IF) + VVM
          ENDIF
          IF (IVU(IDPT).NE.1)  IVUE = 0
*
3700    CONTINUE
*
        IF (IVUE.EQ.1) THEN
*
          XX(3)=XXM/NBCOT
          YY(3)=YYM/NBCOT
          VV(3)=VVM/NBCOT
*
          NUPT2 = IFACP(NBCOT, IF)
          ID2 = ICPR(NUPT2)
          XX(2)=XPROJ(1,ID2)
          YY(2)=XPROJ(2,ID2)
          ZZ(2)=XPROJ(3,ID2)
          IF (MCHAM.EQ.0) THEN
            VV(2) = VCPCHA(NUPT2)
          ELSE
            VV(2) = XFACP(NBCOT, IF)
          ENDIF
*
*         Boucle sur tous les triangles
*
          DO 3705 , ICT = 1, NBCOT
*
            NUPT1 = IFACP(ICT, IF)
            ID1 = ICPR(NUPT1)
*
            XX(1)=XPROJ(1,ID1)              
            YY(1)=XPROJ(2,ID1)
            ZZ(1)=XPROJ(3,ID1)
            IF (MCHAM.EQ.0) THEN
              VV(1)= VCPCHA(NUPT1)
            ELSE
              VV(1) = XFACP(ICT, IF)
            ENDIF
            CALL TRISO(VCHC,XX,YY,ZZ,VV,3,NISO)
            XX(2)= XX(1)             
            YY(2)= YY(1)
            ZZ(2)= ZZ(1)
            VV(2)= VV(1)
*
3705      CONTINUE
*
        ENDIF
*
        GOTO 380
 380  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) then
         SEGSUP IPT2
         if (mcham.ne.0) then
          melval=lisref(io)
          segsup melval
         endif
        else
         segdes ipt2
        endif
 490    CONTINUE
      ENDIF
      if (itypel.eq.0) SEGSUP MELEME
      MELEME=MELSAU
      SEGSUP ISEG2,ISEG3,IFAC3,IFAC4,IFAC6,IFAC8,NAUX,TFAC,KFAK
      if (mcham.ne.0) SEGSUP XSEG2,XSEG3,xFAC3,xFAC4,xFAC6,xFAC8
      RETURN
      END