C COML9     SOURCE    FANDEUR   12/07/18    21:15:27     7435           

      SUBROUTINE COML9(iqmod,ipcon,ipinf,indeso,IRETOU,insupp)

*-----------------------------------------------------------------------
* coml9 :
*      traitement non-local
*          pour une loi de melange, etablir la contraite moyenne
*-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC CCOPTIO
-INC CCGEOME
-INC SMCHAML
-INC SMELEME
-INC SMMODEL
-INC DECHE
      SEGMENT INFO
         INTEGER INFELL(16)
      ENDSEGMENT
      LOGICAL lsupco
      CHARACTER*8 lcon

* Obligation d'initialiser ce segment WRK53 (DECHE) compte tenu du 
* fait que les variables de dimensionnement des melval ont le meme 
* nom que des variables contenues dans ce segment.
* Si on ne le fait pas, plantage GEMAT !!!i
* A revoir par la suite pour supprimer l'utilisation du segment wrk53.
      segini,wrk53

      lilcon = ipcon
      IMODEL = IQMOD

      meleme = IMAMOD
      SEGACT,meleme*nomod
      wrk53.nel = num(/2)
      SEGDES,meleme

c     information sur l'element fini
c____________________________________________________________________
      if (ipinf.ne.0) then
        INFO=IPINF
c*      segact,info
        MINTE  = INFELL(11)
        wrk53.nbptel = INFELL(4)
c*      segdes,info
      else 
        MINTE  = INFMOD(2+insupp)
        wrk53.nbptel = INFELE(4)
      endif
c
c modele de melange mecanique : nom des composantes
c
      lsupco=.false.
      do iv = 1 , ivamod(/1)
        if (tymode(iv).eq.'IMODEL') then
          imode1 = ivamod(iv)
          segact,imode1
          if (imode1.formod(1).eq.'MECANIQUE') then
            if (imode1.lnomid(4).ne.0) then
              mocomp = imode1.lnomid(4)
            else 
              lsupco=.true.          
              CALL IDCONT(IMODE1,IFOUR,MOCOMP,NOBL,NFAC)
            endif
            goto 11
          endif
        endif
      enddo

 11   CONTINUE
      lesupp = 5
      nomid = mocomp
      segact nomid*nomod
      nobl = lesobl(/2)
      nfac = lesfac(/2)        

      ijlcon = lilcon(/1)
      iilcon = ijlcon + nobl + nfac
      segadj lilcon

      do icom = 1,nobl
* cree deche
        N3 = 6
        segini deche
        lilcon(ijlcon + icom) = deche
        indec  = indeso
        nomdec = lesobl(icom)
        condec = CONMOD
        typdec = 'REAL*8'
        imadec = IMAMOD
        ifodec = IFOUR
        infdec(1) = 0
        infdec(2) = 0
        infdec(3) = NIFOUR
        infdec(4) = MINTE
        infdec(5) = 0
        infdec(6) = lesupp
* cree melval
c* Attention n2ptel <=> wrk53.n2ptel & n2el <=> wrk53.n2el
        n1ptel = wrk53.nbptel
        n1el   = wrk53.nel
        n2ptel = 0
        n2el   = 0
        segini,melval
        ieldec = melval

* boucle sur les modeles
        do 31 iv = 1,ivamod(/1)
            if (tymode(iv).eq.'IMODEL') then
              imode1 = ivamod(iv)
              segact,imode1
            else 
              goto 31
            endif
* somme les contributions
        do idcon = 1, lilcon(/1)
          dec1 = lilcon(idcon) 
          if (dec1.gt.0) then
          if (dec1.nomdec.eq.nomdec.and.dec1.condec.eq.imode1.conmod)
     & then
            melva1 = dec1.ieldec
            segact,melva1
            im1 = melva1.velche(/1)
            jm1 = melva1.velche(/2)

            do idco2 = 1,lilcon(/1)
              dec2 = lilcon(idco2)
              if (dec2.gt.0) then
C-??-??-      if (dec2.nomdec(1:8).eq.imode1.conmod(17:24)) then
              if (dec2.nomdec(1:4).eq.imode1.conmod(17:21)) then
                melva2 = dec2.ieldec
                segact,melva2
                im2 = melva2.velche(/1)
                jm2 = melva2.velche(/2)
*
               do jel = 1,n1el
                j1 = min(jel,jm1)
                j2 = min(jel,jm2)
                do jptel = 1,n1ptel
                  i1 = min(jptel,im1)
                  i2 = min(jptel,im2)
       velche(jptel,jel) = ( melva1.velche(i1,j1)*melva2.velche(i2,j2))
     &              + velche(jptel,jel)
                enddo
               enddo
               segdes,melva2
              endif
              endif
            enddo
            segdes,melva1
          endif
          endif
        enddo
 31    continue
      enddo

      segdes,nomid
      if (lsupco) segsup,nomid
      segsup,wrk53

      RETURN
      END