C IMPF      SOURCE    FANDEUR   11/08/10    21:15:05     7076           
*
*  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 CCOPTIO
*
-INC SMCOORD
-INC SMELEME
*
      segment icpr(nbptr)
*
      idimp1 = IDIM + 1
*
* 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) .ne. 0) call erreur(16)
      if (ipt1.itypel.ne.22 .and. ipt1.itypel.ne.2) call erreur(16)
      if (ierr.ne.0) goto 990
*
      nbnnin = ipt1.num(/1)
      nbelin = ipt1.num(/2)
*
      segact mcoord*mod
      nbptin = xcoor(/1) / idimp1
*
*=========================================================
* Elements de frottement <- Elements de contact (type 22)
*=========================================================
      if (ipt1.itypel.eq.2) goto 100
*
*  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).
      nbs = 1
      if (idim.eq.3) nbs = 2
*
      segini,meleme=ipt1
      nbnn   = nbnnin + nbs
      nbelem = nbelin
      nbref  = 0
      nbsous = 0
      segadj,meleme
*
      nbpts = nbptin + (nbs*nbelin)
      segadj mcoord
*
      do 10 iel = 1, nbelem
        ip = (ipt1.num(1,iel)-1) * idimp1
        xb = xcoor(ip+1)
        yb = xcoor(ip+2)
        zb = xcoor(ip+3)
        if (idim.eq.3) tb = xcoor(ip+4)
        ia = nbptin + nbs*(iel-1)
        ip = (ia-1) * idimp1
        do 11 in = 1, nbs
          ia = ia + 1
          ip = ip + idimp1
          num(nbnnin+in,iel) = ia
          xcoor(ip+1) = xb
          xcoor(ip+2) = yb
          xcoor(ip+3) = zb
          if (idim.eq.3) xcoor(ip+4) = tb
  11    continue
  10  continue
      goto 900

*============================
* Elements de cable frottant
*============================
 100  continue
*
*  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