C COML9     SOURCE    MB234859  25/09/08    21:15:17     12358          

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

*-----------------------------------------------------------------------
* coml9 :
*      traitement non-local
*          pour une loi de melange, etablir la contraite moyenne
*     nota : le modele 'PARALLELE' ne calcule pas par lui-meme les coef
*            de phase
*-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCHAML
-INC SMELEME
-INC SMMODEL
-INC DECHE

      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.
c      segini,wrk53
      wrk53 = iwrk53

      lilcon = ipcon
      IMODEL = IQMOD

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

c     information sur l'element fini
c____________________________________________________________________
      MINTE  = INFMOD(2+insupp)
      wrk53.nbptel = INFELE(4)
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'
        typree = .true.
        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(1:LCONMO).eq.imode1.conmod(1:LCONMO))
     & then
*            write(6,*) 'c9',nomdec,dec1,dec1.indec,iv,idcon
            melva1 = ABS(dec1.ieldec)
            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:20)) then
*          write(6,*) 'c92',dec2,dec2.nomdec,dec2.indec,iv,idcon,idco2              
                melva2 = ABS(dec2.ieldec)
                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
               goto 31
              endif
              endif
            enddo
          endif
          endif
        enddo
 31    continue
      enddo

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

      RETURN
      END