C IMPF      SOURCE    PV        20/04/01    21:15:37     10569          
*
*  Fabrique un maillage :
*  - d'elements de frottement a partir d'elements de contact
*  - de cables frottants a partir du maillage des cables
*
      SUBROUTINE IMPF
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
*

-INC PPARAM
-INC CCOPTIO
*
-INC SMCOORD
-INC SMELEME
-INC CCGEOME
*
      segment icpr(nbpts)
*
      idimp1 = IDIM + 1
      segact mcoord*mod
      nbptin = nbpts
      nbpts=nbptin
*
*
* Lecture du maillage de contact / des cables frottants
*
      call lirobj('MAILLAGE',ipt1,1,iretou)
      if (ierr.ne.0) return
*
      segact ipt1
*
      if (ipt1.lisous(/1) .eq.0) then
** elem type 2 ==> cable frottant
       if (ipt1.itypel.eq.2) goto 100
      endif
*
      nbnnin = ipt1.num(/1)
      nbelin = ipt1.num(/2)
*
*=========================================================
* Elements de frottement <- Elements de contact (type 22)
*=========================================================
*
*  Nombre de noeud(s) support(s) supplementaire(s) pour le frottement
*  a ajouter a chaque element de contact pour faire l'element de
*  frottement correspondant
*  Le(s) noeud(s) supplementaire(s) a(ont) les memes coordonnees que
*  le noeud support du contact (1er noeud de l'element de contact).
*  attention:
*  creation des noeuds supports différés à la première utilisation en 3d
*  on se sert de icpr pour stocker le mult de frottement associé a un mult de contact
*  de facon a ne le creer qu'une fois
      segini icpr
      nbs = 1
      if (idim.eq.3) nbs = 2
      ipt2=ipt1
      segact ipt2
      nbsous=max(1,ipt1.lisous(/1))
      nbref=0
      nbnn=0
      nbelem=0
      segini ipt4
      do is=1,nbsous
       if (ipt1.lisous(/1).ne.0) ipt2=ipt1.lisous(is)
       segact ipt2
       nbnn=ipt2.num(/1)+nbs
       nbelem=ipt2.num(/2)
       nbsous=0
       segini ipt3
       ipt4.lisous(is)=ipt3
       ipt3.itypel=22
       do iel=1,ipt2.num(/2)
        do in=1,ipt2.num(/1)
          ipt3.num(in,iel)=ipt2.num(in,iel)
        enddo
          ipt3.icolor(iel)=ipt2.icolor(iel)
        il=ipt2.num(1,iel)
        if (icpr(il).eq.0) then
          nbpts=nbpts+1
          icpr(il)=nbpts
          if (idim.eq.3) nbpts=nbpts+1
        endif
        ipt3.num(ipt2.num(/1)+1,iel)=icpr(il)
        if (idim.eq.3) ipt3.num(ipt2.num(/1)+2,iel)=icpr(il)+1
       enddo
       ipt4.lisous(is)=ipt3
      enddo
*  remplissage mcoord
      segadj mcoord
      do i=1,icpr(/1)
       ip=icpr(i)
       if (ip.ne.0) then
        ip=(ip-1)*(idim+1)
        xcoor(ip+1)=xcoor((i-1)*(idim+1)+1)
        xcoor(ip+2)=xcoor((i-1)*(idim+1)+2)
        if (idim.eq.3) xcoor(ip+3)=xcoor((i-1)*(idim+1)+3)
        if (idim.eq.3) then
        ip=icpr(i)+1
        ip=(ip-1)*(idim+1)
         xcoor(ip+1)=xcoor((i-1)*(idim+1)+1)
         xcoor(ip+2)=xcoor((i-1)*(idim+1)+2)
         xcoor(ip+3)=xcoor((i-1)*(idim+1)+3)
        endif
       endif
      enddo
*
      meleme=ipt4
      if (ipt4.lisous(/1).eq.1) then
       meleme=ipt4.lisous(1)
       segsup ipt4
      endif

      goto 900

*============================
* Elements de cable frottant
*============================
 100  continue
*
      nbnnin = ipt1.num(/1)
      nbelin = ipt1.num(/2)
*
      segact mcoord
      nbptin = nbpts
*
*  IDIM element(s) de frottement en chaque point geometrique definissant
*  le reseau des cables (un seul element associe au noeud commun a
*  plusieurs elements de cable pour chaque direction de l'espace)
      nbptr = nbptin
      segini icpr
      nbs = 0
      do 101 iel = 1, nbelin
        do 102 in = 1, nbnnin
          ia = ipt1.num(in,iel)
          if (icpr(ia).ne.0) goto 102
          nbs = nbs+1
          icpr(ia) = nbs
 102    continue
 101  continue
*
      nbnn   = 2
      nbelem = nbs*idim
      nbref  = 0
      nbsous = 0
      segini meleme
      itypel = 22
*
      nbpts = nbptin + (nbs*idim)
      segadj,mcoord
*
      nbel = 0
      ndec = (nbptin-1) * idimp1
      do 103 iel = 1, nbelin
        do 104 in = 1, nbnnin
          ia = ipt1.num(in,iel)
          if (icpr(ia).eq.0) goto 104
          icpr(ia) = 0
          ip = (ia-1)*idimp1
          xb = xcoor(ip+1)
          yb = xcoor(ip+2)
          zb = xcoor(ip+3)
          if (idim.eq.3) tb = xcoor(ip+4)
          do 105 id = 1,idim
            nbel = nbel+1
            ndec = ndec+idimp1
            xcoor(ndec+1) = xb
            xcoor(ndec+2) = yb
            xcoor(ndec+3) = zb
            if (idim.eq.3) xcoor(ndec+4) = tb
            num(1,nbel) = nbptin + nbel
            num(2,nbel) = ia
  105     continue
  104   continue
  103 continue
*
      segsup icpr
c*      goto 900
*
*=======
* Fin : Ecriture du MELEME de frottement
*=======
 900  CONTINUE
      segdes,meleme
      call ecrobj('MAILLAGE',meleme)

 990  CONTINUE
      segdes,ipt1

      return
      end