C ENVVOL    SOURCE    GOUNAND   17/12/05    21:16:07     9645           
      SUBROUTINE ENVVOL

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC CCGEOME
-INC SMCOORD

      SEGMENT IFAC3(4,NFAC3)
      SEGMENT IFAC4(5,NFAC4)
      SEGMENT IFAC6(7,NFAC6)
      SEGMENT IFAC8(9,NFAC8)
      SEGMENT IPPOL(NTPOL)
      SEGMENT NTFAC(NFAC)
      SEGMENT KFAK(NFAC)
      SEGMENT NAUX(max(2,NFAC))
      SEGMENT XCENT(3,NBELEM)
      character*4 lnoid(1)

c==== LECTURE D UN MOT CLE ORIE pour ORIENTER L ENVELOPPE =============
      PARAMETER (LCLE = 1)
      CHARACTER*4 MCLE(LCLE)
*dbg      PARAMETER (LOPT=1)
*dbg      CHARACTER*4 MOPT(LOPT)
*dbg      DATA MOPT/'OLD '/
      DATA MCLE/'ORIE'/
      data lnoid/'NOID'/
*dbg      IOPT=0
*dbg      CALL LIRMOT(MOPT,LOPT,IOPT,0)
      ICLE=0
      CALL LIRMOT(MCLE,LCLE,ICLE,0)
*dbg      IF (IOPT.EQ.0.AND.ICLE.EQ.0) THEN
      IF (ICLE.EQ.0) THEN
         CALL ENVVO2(0)
         RETURN
      ENDIF
      call lirmot(lnoid,1,inoid,0)

c==== LECTURE ET OUVERTURE DU MELEME ==================================
c     et eventuelle boucle 10 sur les ojbets meleme elementaires
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
      IF (IERR.NE.0) RETURN
      SEGACT MELEME
c     on compte le nombre d elements dont les faces possedent 3,4,6 ou 8
c     noeuds => NFAC3,4,6,8
      NFAC3=0
      NFAC4=0
      NFAC6=0
      NFAC8=0
      NTPOL = 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)
c     LTEL,LDEL LFAC de CCGEOME remplis par bdata
         ILTEL=LTEL(1,IPT1.ITYPEL)
         IF (ILTEL.EQ.0) GOTO 12
         ILTAD=LTEL(2,IPT1.ITYPEL)
c --- boucle sur les faces de chaque elements ---
         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
c --- fin de boucle sur les faces de chaque elements ---
 12      CONTINUE
 10   CONTINUE
c       write(6,*) 'dimension de NFAC3,4,6,8=',NFAC3,NFAC4,NFAC6,NFAC8

c==== CREATION DES FACES ==============================================
c     IFAC3,4,6,8(i,j)=noeuds de la jieme face
      SEGINI IFAC3,IFAC4,IFAC6,IFAC8,IPPOL
      NFAC3=0
      NFAC4=0
      NFAC6=0
      NFAC8=0
      NTPOL=0
c     eventuelle boucle 50 sur les ojbets meleme elementaires
      DO 50 IOB=1,MAX(1,LISOUS(/1))
         IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB)
         segact ipt1
         NBELEM=IPT1.NUM(/2)
C     calcul du centre des noeuds des elements
         if (ICLE.eq.1) then
            segini,XCENT
            NBNN=IPT1.NUM(/1)
            IDIM1 = IDIM+1
            do iel=1,NBELEM
               XG = 0.D0
               YG = 0.D0
               ZG = 0.D0
               do inode=1,NBNN
                  IP1 = IPT1.NUM(inode,iel) - 1
                  XG = XG + XCOOR(IP1*IDIM1+1)
                  YG = YG + XCOOR(IP1*IDIM1+2)
                  ZG = ZG + XCOOR(IP1*IDIM1+3)
               enddo
               XCENT(1,iel)=XG/NBNN
               XCENT(2,iel)=YG/NBNN
               XCENT(3,iel)=ZG/NBNN
            enddo
c          write(6,*) 'XCENT=',(XCENT(1,iou),iou=1,min(4,NBELEM))
c          write(6,*) '      ',(XCENT(2,iou),iou=1,min(4,NBELEM))
c          write(6,*) '      ',(XCENT(3,iou),iou=1,min(4,NBELEM))
         endif
         ILTEL=LTEL(1,IPT1.ITYPEL)
         IF (ILTEL.EQ.0) GOTO 52
         ILTAD=LTEL(2,IPT1.ITYPEL)
c --- boucle 60 sur faces d'1 type d'element ------------------
         DO 60 IF=1,ILTEL
            ITYP=LDEL(1,ILTAD+IF-1)
            IAD=LDEL(2,ILTAD+IF-1)
c --- boucle 66 sur elements ---------------------------------
            DO 66 IEL=1,NBELEM
               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)
               if(ICLE.eq.1) call envori(IFAC3,0,0,0,NFAC3,XCENT,IEL)
               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)
               if(ICLE.eq.1) call envori(0,IFAC4,0,0,NFAC4,XCENT,IEL)
               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)
               if(ICLE.eq.1) call envori(0,0,IFAC6,0,NFAC6,XCENT,IEL)
               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)
               if(ICLE.eq.1) call envori(0,0,0,IFAC8,NFAC8,XCENT,IEL)
               GOTO 65
 65            CONTINUE
 66         CONTINUE
c --- fin de boucle 66 sur elements ---------------------------------
 60      CONTINUE
c --- fin de boucle 60 sur faces d'1 type d'element ------------------
  52  CONTINUE
      IF (ITYP.EQ.6) THEN
C     Polygone
         NTPOL = NTPOL+1
         IPPOL(NTPOL)= IPT1
      ELSE
         IF (LISOUS(/1).NE.0) SEGDES IPT1
      ENDIF
 50   CONTINUE
      SEGDES MELEME
      if (ICLE.eq.1) segsup,XCENT

C ======================================================================
C  IL 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 ======================================================================
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
               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
               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
               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
               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
         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))
 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
         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))
 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
         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))
 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
         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))
 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
      IF (NBSOU2.EQ.0.AND.NTPOL.EQ.0.AND.inoid.eq.0) CALL ERREUR(26)
      IF (NBSOU2.NE.1.OR.NTPOL.GE.0) GOTO 700
      CALL ECROBJ('MAILLAGE',IPT1+IPT2+IPT3+IPT4+ipt5)
      SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NTFAC,KFAK,NAUX
      RETURN
 700  CONTINUE
      NBREF=0
      NBSOUS=NBSOU2+NTPOL
      NBNN=0
      NBELEM=0
      SEGINI IPT5
      I=0
      IF (IPT1.EQ.0) GOTO 701
      I=I+1
      IPT5.LISOUS(I)=IPT1
 701  CONTINUE
      IF (IPT2.EQ.0) GOTO 702
      I=I+1
      IPT5.LISOUS(I)=IPT2
 702  CONTINUE
      IF (IPT3.EQ.0) GOTO 703
      I=I+1
      IPT5.LISOUS(I)=IPT3
 703  CONTINUE
      IF (IPT4.EQ.0) GOTO 704
      I=I+1
      IPT5.LISOUS(I)=IPT4
 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
         endif
         segdes ipt1
 711  continue
      DO 720, IO = 1, NTPOL
         I = I+1
         IPT5.LISOUS(I)=IPPOL(IO)
 720  CONTINUE
      if (ipt5.lisous(/1).eq.1) then
         ipt6=ipt5
         ipt5=ipt6.lisous(1)
         segsup ipt6
      endif
      segdes meleme
      SEGDES IPT5
      CALL ECROBJ('MAILLAGE',IPT5)
      SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NTFAC,KFAK,NAUX,IPPOL
      RETURN
      END