C IMPP1     SOURCE    CHAT      05/01/13    00:34:19     5004           
      SUBROUTINE IMPP1(IPT3,IPT2)
*
* création du maillage support des conditions aux limites de changement
* de phase: création en vue d'un bloquer mini ou d'un bloque maxi.
* C'est a dire que pour chaque point on cree un multiplicateurs
* les elements crees sont de type 22 
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
      segment icpr(XCOOR(/1)/(IDIM+1))
      segini icpr
      meleme=ipt3
      segact meleme
      ipt1 = meleme
      do 1 I=1,max(1,ipt1.lisous(/1))
       if(ipt1.lisous(/1). NE. 0) then
         meleme = lisous(i)
         segact meleme
       endif
       do 2 J=1,NUM(/2)
       do 2 K = 1, num(/1)
       icpr(num(K,J))=1
   2  continue
      IF(ipt1.lisous(/1). NE. 0) segdes meleme
    1 continue 
      segdes ipt1
      na=0
      do 3 j=1,icpr(/1)
      if(icpr(J).ne.0) then
         na = na + 1
         icpr(j) = na
       endif
   3  continue
      idim1 = idim +1
      nbelem = na
      nbnn = 2
      nbsous=0
      nbref=0
      segini meleme
      itypel=22
      ndec = xcoor(/1)/(IDIM+1)   
      nbpts = ndec  + na 
      segadj mcoord
      nb = na      
      na=0  
      do 4 i=1,icpr(/1)
       if(icpr(i).ne.0) then
        na = na + 1
        nc =  na + ndec
        ncidi=(nc - 1 ) * idim1 +1
        num(1,na) = nc
        num(2,na) = i
        i1 = ( icpr(i) - 1) * idim1 +1
        xcoor(ncidi) = xcoor ( i1)
        xcoor(ncidi+1) = xcoor( i1 + 1)
        if (idim.eq.3) xcoor(ncidi+2) = xcoor( i1 + 2)
      endif
    4  continue
      segdes meleme
      ipt2=meleme
      segsup icpr
      return
      end