C ENVEL1    SOURCE    PV        11/03/08    21:15:33     6888           
*   copier sur envvol avec gestion du chamelem de valeurs associes
*   utilise dans trac cham
*
      SUBROUTINE ENVEL1(MELEME,MELRES)
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC SMELEME
-INC CCGEOME
-INC SMCHAML
      SEGMENT IFAC3(5,NFAC3)
      SEGMENT IFAC4(6,NFAC4)
      SEGMENT IFAC6(8,NFAC6)
      SEGMENT IFAC8(10,NFAC8)
      SEGMENT IPPOL(NTPOL)
      SEGMENT IPREF(NTPOL)
      SEGMENT XFAC3(3,NFAC3)
      SEGMENT XFAC4(4,NFAC4)
      SEGMENT XFAC6(6,NFAC6)
      SEGMENT XFAC8(8,NFAC8)
      SEGMENT NTFAC(NFAC)
      SEGMENT KFAK(NFAC)
      SEGMENT NAUX(NFAC)
      n2ptel=0
      n2el=0
      SEGACT MELEME
      NFAC3=0
      NFAC4=0
      NFAC6=0
      NFAC8=0
      NTPOL=0
      IPT1=MELEME
      SEGACT MELEME
      DO 10 IOB=1,LISOUS(/1)
       IPT1=LISOUS(IOB)
       SEGACT IPT1
      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  NTPOL=NTPOL+1
      GOTO 30
  30  CONTINUE
  13  CONTINUE
  12  CONTINUE
  10  CONTINUE
      SEGINI IFAC3,IFAC4,IFAC6,IFAC8,IPPOL,IPREF
      SEGINI XFAC3,XFAC4,XFAC6,XFAC8
      NFAC3=0
      NFAC4=0
      NFAC6=0
      NFAC8=0
      NTPOL=0
      DO 50 IOB=1,LISOUS(/1)
        IPT1=LISOUS(IOB)
* si objet en double on saute
        do 51 io2=1,iob-1
         if (ipt1.eq.lisous(io2)) goto 50
  51    continue
        SEGACT IPT1
        IELIM=1
        IF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) THEN
*  face non eliminable (pas un volume)
         IELIM=0
        ENDIF
        melval=lisref(iob)
        if (melval.eq.0) goto 50
        segact melval
        lval=velche(/1)
        ival=velche(/2)
        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 66 IEL=1,NBELEM
              ielr=min(ival,iel)
            GOTO (61,62,63,64,65,65),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)
              IFAC3(4,NFAC3)=IPT1.ICOLOR(IEL)
              IFAC3(5,NFAC3)=IELIM
              xFAC3(1,NFAC3)=velche(min(lval,LFAC(IAD)),ielr)
              xFAC3(2,NFAC3)=velche(min(lval,LFAC(IAD+1)),ielr)
              xFAC3(3,NFAC3)=velche(min(lval,LFAC(IAD+2)),ielr)
            GOTO 65
  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)
              IFAC4(5,NFAC4)=IPT1.ICOLOR(IEL)
              IFAC4(6,NFAC4)=IELIM
              xFAC4(1,NFAC4)=velche(min(lval,LFAC(IAD)),ielr)
              xFAC4(2,NFAC4)=velche(min(lval,LFAC(IAD+1)),ielr)
              xFAC4(3,NFAC4)=velche(min(lval,LFAC(IAD+2)),ielr)
              xFAC4(4,NFAC4)=velche(min(lval,LFAC(IAD+3)),ielr)
            GOTO 65
  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)
              IFAC6(7,NFAC6)=IPT1.ICOLOR(IEL)
              IFAC6(8,NFAC6)=IELIM
              xFAC6(1,NFAC6)=velche(min(lval,LFAC(IAD))  ,ielr)
              xFAC6(2,NFAC6)=velche(min(lval,LFAC(IAD+1)),ielr)
              xFAC6(3,NFAC6)=velche(min(lval,LFAC(IAD+2)),ielr)
              xFAC6(4,NFAC6)=velche(min(lval,LFAC(IAD+3)),ielr)
              xFAC6(5,NFAC6)=velche(min(lval,LFAC(IAD+4)),ielr)
              xFAC6(6,NFAC6)=velche(min(lval,LFAC(IAD+5)),ielr)
            GOTO 65
  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)
              IFAC8(9,NFAC8)=IPT1.ICOLOR(IEL)
              IFAC8(10,NFAC8)=IELIM
              xFAC8(1,NFAC8)=velche(min(lval,LFAC(IAD))  ,ielr)
              xFAC8(2,NFAC8)=velche(min(lval,LFAC(IAD+1)),ielr)
              xFAC8(3,NFAC8)=velche(min(lval,LFAC(IAD+2)),ielr)
              xFAC8(4,NFAC8)=velche(min(lval,LFAC(IAD+3)),ielr)
              xFAC8(5,NFAC8)=velche(min(lval,LFAC(IAD+4)),ielr)
              xFAC8(6,NFAC8)=velche(min(lval,LFAC(IAD+5)),ielr)
              xFAC8(7,NFAC8)=velche(min(lval,LFAC(IAD+6)),ielr)
              xFAC8(8,NFAC8)=velche(min(lval,LFAC(IAD+7)),ielr)
            GOTO 65
  65        CONTINUE
  66      CONTINUE
  60    CONTINUE
  52    CONTINUE
        IF (ITYP.EQ.6) THEN
C         Polygone
          NTPOL = NTPOL+1 
          IPPOL(NTPOL)= IPT1
          SEGINI,MELVA1 = MELVAL
          IPREF(NTPOL) = MELVA1
        ELSE
          IF (LISOUS(/1).NE.0) SEGDES IPT1
        ENDIF
  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
      SEGINI NTFAC,KFAK
      IF (NFAC3.EQ.0) GOTO 101
      DO 102 I=1,NFAC3
      NTFAC(I)=IFAC3(1,I)+IFAC3(2,I)+IFAC3(3,I)
      KFAK(I)=I
 102  CONTINUE
 101  CONTINUE
      IF (NFAC4.EQ.0) GOTO 103
      DO 104 I=1,NFAC4
      NTFAC(I+NFAC3)=IFAC4(1,I)+IFAC4(2,I)+IFAC4(3,I)+IFAC4(4,I)
      KFAK(I+NFAC3)=I
 104  CONTINUE
 103  CONTINUE
      IF (NFAC6.EQ.0) GOTO 105
      DO 106 I=1,NFAC6
      NTFAC(I+NFAC3+NFAC4)=IFAC6(1,I)+IFAC6(2,I)+IFAC6(3,I)
     # +IFAC6(4,I)+IFAC6(5,I)+IFAC6(6,I)
      KFAK(I+NFAC3+NFAC4)=I
 106  CONTINUE
 105  CONTINUE
      IF (NFAC8.EQ.0) GOTO 107
      DO 108 I=1,NFAC8
      NTFAC(I+NFAC3+NFAC4+NFAC6)=IFAC8(1,I)+IFAC8(2,I)+IFAC8(3,I)
     # +IFAC8(4,I)+IFAC8(5,I)+IFAC8(6,I)+IFAC8(7,I)+IFAC8(8,I)
      KFAK(I+NFAC3+NFAC4+NFAC6)=I
 108  CONTINUE
 107  CONTINUE
C  IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT NTFAC
      SEGINI NAUX
      DO 300 ITYP=1,4
      GOTO (301,302,303,304),ITYP
 301  CONTINUE
      IF (NFAC3.LE.1) GOTO 300
      NAUX(1)=1
      NAUX(2)=NFAC3
      GOTO 310
 302  CONTINUE
      IF (NFAC4.LE.1) GOTO 300
      NAUX(1)=NFAC3+1
      NAUX(2)=NFAC3+NFAC4
      GOTO 310
 303  CONTINUE
      IF (NFAC6.LE.1) GOTO 300
      NAUX(1)=NFAC3+NFAC4+1
      NAUX(2)=NFAC3+NFAC4+NFAC6
      GOTO 310
 304  CONTINUE
      IF (NFAC8.LE.1) GOTO 300
      NAUX(1)=NFAC3+NFAC4+NFAC6+1
      NAUX(2)=NFAC
      GOTO 310
 310  CONTINUE
      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
      NPV=0
*     DO 207 J=IPB,IPH
*     NPV=NPV+NTFAC(J)
*207  CONTINUE
*     NPV=NPV/(IPH-IPB+1)
      NPV=(NTFAC(IPB)+NTFAC(IPH))/2
 242  JPB=JPB+1
      IF (JPH.EQ.JPB) GOTO 245
      IF (NTFAC(JPB).LE.NPV) GOTO 243
      GOTO 242
 243  JPH=JPH-1
      IF (JPH.EQ.JPB) GOTO 245
      IF (NTFAC(JPH).GE.NPV) GOTO 244
      GOTO 243
 244  IAUX=KFAK(JPB)
      KFAK(JPB)=KFAK(JPH)
      KFAK(JPH)=IAUX
      NTAUX=NTFAC(JPB)
      NTFAC(JPB)=NTFAC(JPH)
      NTFAC(JPH)=NTAUX
      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 (NTFAC(JPB).LE.NPV) 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
 300  CONTINUE
C  LES FACES SONT CLASSEES DANS KFAK IL FAUT ELIMINER LES FACES EN DOUBL
C  ELLES SONT PAR TYPE LES UNES DERRIERES LES AUTRES LES PLUS HAUTES
C  DEVANT
      IF (IIMPI.NE.0) WRITE (IOIMP,9111) (KFAK(I),NTFAC(I),I=1,NFAC)
 9111 FORMAT(5(2X,2I6))
      DO 400 ITYP=1,4
      GOTO (401,402,403,404),ITYP
 401  IF (NFAC3.LE.1) GOTO 400
      IDEB=1
      IFIN=NFAC3
      GOTO 410
 402  IF (NFAC4.LE.1) GOTO 400
      IDEB=NFAC3+1
      IFIN=NFAC3+NFAC4
      GOTO 410
 403  IF (NFAC6.LE.1) GOTO 400
      IDEB=NFAC3+NFAC4+1
      IFIN=NFAC3+NFAC4+NFAC6
      GOTO 410
 404  IF (NFAC8.LE.1) GOTO 400
      IDEB=NFAC3+NFAC4+NFAC6+1
      IFIN=NFAC
      GOTO 410
 410  CONTINUE
      IFINM=IFIN-1
      DO 450 I1=IDEB,IFINM
      NTI1=NTFAC(I1)
      IF (NTI1.EQ.0) GOTO 450
      IDEB1=I1+1
      DO 460 I2=IDEB1,IFIN
      NTI2=NTFAC(I2)
      IF (NTI2.EQ.0) GOTO 460
      IF (NTI2.NE.NTI1) GOTO 450
      IR1=KFAK(I1)
      IR2=KFAK(I2)
      GOTO (470,480,490,500),ITYP
 470  CONTINUE
      IF (IFAC3(5,IR1).EQ.0) GOTO 520
      IF (IFAC3(5,IR2).EQ.0) GOTO 520
      DO 471 J1=1,3
      INU=IFAC3(J1,IR1)
      DO 472 J2=1,3
      IF (INU.EQ.IFAC3(J2,IR2)) GOTO 471
 472  CONTINUE
      GOTO 520
 471  CONTINUE
      GOTO 510
 480  CONTINUE
      IF (IFAC4(6,IR1).EQ.0) GOTO 520
      IF (IFAC4(6,IR2).EQ.0) GOTO 520
      DO 481 J1=1,4
      INU=IFAC4(J1,IR1)
      DO 482 J2=1,4
      IF (INU.EQ.IFAC4(J2,IR2)) GOTO 481
 482  CONTINUE
      GOTO 520
 481  CONTINUE
      GOTO 510
 490  CONTINUE
      IF (IFAC6(8,IR1).EQ.0) GOTO 520
      IF (IFAC6(8,IR2).EQ.0) GOTO 520
      DO 491 J1=1,6
      INU=IFAC6(J1,IR1)
      DO 492 J2=1,6
      IF (INU.EQ.IFAC6(J2,IR2)) GOTO 491
 492  CONTINUE
      GOTO 520
 491  CONTINUE
      GOTO 510
 500  CONTINUE
      IF (IFAC8(10,IR1).EQ.0) GOTO 520
      IF (IFAC8(10,IR2).EQ.0) GOTO 520
      DO 501 J1=1,8
      INU=IFAC8(J1,IR1)
      DO 502 J2=1,8
      IF (INU.EQ.IFAC8(J2,IR2)) GOTO 501
 502  CONTINUE
      GOTO 520
 501  CONTINUE
      GOTO 510
 520  CONTINUE
      GOTO 460
 510  CONTINUE
C  DEUX FACES EGALES ON LES SUPPRIMENT
      NTFAC(I1)=0
      NTFAC(I2)=0
      GOTO 450
 460  CONTINUE
 450  CONTINUE
 400  CONTINUE
      IPT1=0
      IPT2=0
      IPT3=0
      IPT4=0
      NBSOUS=0
      NBREF=0
      NBSOU2=0
      DO 600 ITY=1,4
      GOTO (610,620,630,640),ITY
 610  CONTINUE
      IF (NFAC3.EQ.0) GOTO 600
      IDEB=1
      IFIN=NFAC3
      NBELEM=0
      DO 611 I=IDEB,IFIN
      IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
 611  CONTINUE
      IF (NBELEM.EQ.0) GOTO 600
      NBSOU2=NBSOU2+1
      NBNN=3
      SEGINI IPT1
      IPT1.ITYPEL=4
      n1ptel=3
      n1el=nbelem
      segini melva1
      JAUX=0
      DO 612 J=IDEB,IFIN
      IF (NTFAC(J).EQ.0) GOTO 612
      JAUX=JAUX+1
      IPT1.ICOLOR(JAUX)=IFAC3(4,KFAK(J))
      DO 613 I=1,NBNN
      IPT1.NUM(I,JAUX)=IFAC3(I,KFAK(J))
      melva1.velche(I,JAUX)=xFAC3(I,KFAK(J))
 613  CONTINUE
 612  CONTINUE
      SEGDES IPT1
      GOTO 600
 620  CONTINUE
      IF (NFAC4.EQ.0) GOTO 600
      IDEB=NFAC3+1
      IFIN=NFAC3+NFAC4
      NBELEM=0
      DO 621 I=IDEB,IFIN
      IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
 621  CONTINUE
      IF (NBELEM.EQ.0) GOTO 600
      NBSOU2=NBSOU2+1
      NBNN=4
      SEGINI IPT2
      IPT2.ITYPEL=8
      n1ptel=4
      n1el=nbelem
      segini melva2
      JAUX=0
      DO 622 J=IDEB,IFIN
      IF (NTFAC(J).EQ.0) GOTO 622
      JAUX=JAUX+1
      IPT2.ICOLOR(JAUX)=IFAC4(5,KFAK(J))
      DO 623 I=1,NBNN
      IPT2.NUM(I,JAUX)=IFAC4(I,KFAK(J))
      melva2.velche(I,JAUX)=xFAC4(I,KFAK(J))
 623  CONTINUE
 622  CONTINUE
      SEGDES IPT2
      GOTO 600
 630  CONTINUE
      IF (NFAC6.EQ.0) GOTO 600
      IDEB=NFAC3+NFAC4+1
      IFIN=NFAC3+NFAC4+NFAC6
      NBELEM=0
      DO 631 I=IDEB,IFIN
      IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
 631  CONTINUE
      IF (NBELEM.EQ.0) GOTO 600
      NBSOU2=NBSOU2+1
      NBNN=6
      SEGINI IPT3
      IPT3.ITYPEL=6
      n1ptel=6
      n1el=nbelem
      segini melva3
      JAUX=0
      DO 632 J=IDEB,IFIN
      IF (NTFAC(J).EQ.0) GOTO 632
      JAUX=JAUX+1
      IPT3.ICOLOR(JAUX)=IFAC6(7,KFAK(J))
      DO 633 I=1,NBNN
      IPT3.NUM(I,JAUX)=IFAC6(I,KFAK(J))
      melva3.velche(I,JAUX)=xFAC6(I,KFAK(J))
 633  CONTINUE
 632  CONTINUE
      SEGDES IPT3
      GOTO 600
 640  CONTINUE
      IF (NFAC8.EQ.0) GOTO 600
      IDEB=NFAC3+NFAC4+NFAC6+1
      IFIN=NFAC
      NBELEM=0
      DO 641 I=IDEB,IFIN
      IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
 641  CONTINUE
      IF (NBELEM.EQ.0) GOTO 600
      NBSOU2=NBSOU2+1
      NBNN=8
      SEGINI IPT4
      IPT4.ITYPEL=10
      n1ptel=8
      n1el=nbelem
      segini melva4
      JAUX=0
      DO 642 J=IDEB,IFIN
      IF (NTFAC(J).EQ.0) GOTO 642
      JAUX=JAUX+1
      IPT4.ICOLOR(JAUX)=IFAC8(9,KFAK(J))
      DO 643 I=1,NBNN
      IPT4.NUM(I,JAUX)=IFAC8(I,KFAK(J))
      melva4.velche(I,JAUX)=xFAC8(I,KFAK(J))
 643  CONTINUE
 642  CONTINUE
      SEGDES IPT4
      GOTO 600
 600  CONTINUE
*  on rajoute les points et les segments qui pouvaient  etre dans le
*  maillage initial
      ipt5=0
      segact meleme
      ipt6=meleme
      do 710 io=1,max(1,lisous(/1))
      if (lisous(/1).ne.0) ipt6=lisous(io)
      segact ipt6
      if (ipt6.itypel.le.3) then
       nbsou2=nbsou2+1
       ipt5=ipt6
      endif
      segdes ipt6
 710  continue
      segdes meleme
      NBSOUS=NBSOU2+NTPOL
      IF (NBSOUS.EQ.0) CALL ERREUR(26)
      NBREF=nbsous
      NBNN=0
      NBELEM=0
      SEGINI IPT5
      I=0
      IF (IPT1.EQ.0) GOTO 701
      I=I+1
      IPT5.LISOUS(I)=IPT1
      IPT5.LISref(I)=melva1
 701  CONTINUE
      IF (IPT2.EQ.0) GOTO 702
      I=I+1
      IPT5.LISOUS(I)=IPT2
      IPT5.LISref(I)=melva2
 702  CONTINUE
      IF (IPT3.EQ.0) GOTO 703
      I=I+1
      IPT5.LISOUS(I)=IPT3
      IPT5.LISref(I)=melva3
 703  CONTINUE
      IF (IPT4.EQ.0) GOTO 704
      I=I+1
      IPT5.LISOUS(I)=IPT4
      IPT5.LISref(I)=melva4
 704  CONTINUE
      segact meleme
      ipt1=meleme
      do 711 io=1,max(1,lisous(/1))
      if (lisous(/1).ne.0) ipt1=lisous(io)
      segact ipt1
      if (ipt1.itypel.le.3) then
       I=I+1
       IPT5.LISOUS(I)=IPT1
       IPT5.LISref(I)=lisref(io)
      endif
      segdes ipt1
 711  continue
      DO 720, IO = 1, NTPOL
        I= I+1
        IPT5.LISOUS(I) = IPPOL(IO)
        IPT5.LISREF(I) = IPREF(IO)
 720  CONTINUE
      segdes meleme
      melres=ipt5
      SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NTFAC,KFAK,NAUX,IPPOL,IPREF
      SEGSUP xFAC3,xFAC4,xFAC6,xFAC8
      RETURN
      END