C CFND      SOURCE    CHAT      11/03/16    21:16:41     6902           
      subroutine cfnd
      implicit real*8(a-h,o-z)
      implicit integer (i-n)
* rendre un chpoint compatible avec des relations de conformités
-INC CCOPTIO
-INC SMMODEL
-INC SMELEME
-INC SMCHPOI
-INC SMRIGID
-INC CCGEOME
-INC CCHAMP
-INC SMCOORD
-INC SMLMOTS
      logical ltelq
      pointeur nomid1.nomid
      segment icpr(xcoor(/1)/(idim+1))
*      write(6,*) ' entree dans depcom'
      call lirobj('MMODEL  ',mmode1,1,iretou)
      if(ierr.ne.0) return
      call lirobj('CHPOINT ',mchpo1,1,iretou)
      if(ierr.ne.0) return      
      segini,mmodel=mmode1
      segini,mchpoi=mchpo1
      icofo=0
      do ia=1,kmodel(/1)
      imodel=kmodel(ia)
      segact imodel
      if(nefmod.eq.22) then
        icofo=icofo+1
        kmodel(icofo)=imodel
      else
        segdes imodel
      endif
      enddo
      if(icofo.eq.0) then
       segsup mmodel
       segdes mchpoi
       call ecrobj('CHPOINT ',mchpoi)
       return
      endif
*
*   il existe des relations de conformités
*
* 
* verif le chpoint n'a qu'une seule zone
      segini,mchpoi=mchpo1
      if(ipchp(/1).ne.1) then
        call erreur (21)
        segsup mchpoi
        return
      endif
      msoupo=ipchp(1)
      segact msoupo
*
* on fabrique les matrices de liaisons et un maillage contenant
* les noeuds dépendants
*  
       nrigel=icofo
       nrige=8
       segini ri6 
       nbnn=1
       nbsous=0
       nbref=0
      do ia=1,icofo
        nbelea=nbelem
        imodel=kmodel(ia)
        ipt2=imamod
                                                      
       SEGACT IPT2                                                      
       nbelem=ipt2.num(/2)
       segini meleme
       do ib=1,nbelem
       num(1,ib)=ipt2.num(2,ib)
       enddo
       if(ia.eq.1) then
         ipt1=meleme
       else
         ltelq=.false.
         call fuse (ipt1,meleme,ipt3,ltelq)
         ipt1=ipt3
       endif       
      IF (IPT2.ICOLOR(1).EQ.1) IDEBUT=1
      IF (IPT2.ICOLOR(1).EQ.2) IDEBUT=3
      IF (IPT2.ICOLOR(1).EQ.3) IDEBUT=6
      IF (IPT2.ICOLOR(1).EQ.4) IDEBUT=10
      IF (IPT2.ICOLOR(1).EQ.5) IDEBUT=16
      IF (IPT2.ICOLOR(1).EQ.6) IDEBUT=24
C====================                                                   
C *** SEGMENT XMATRI                                                    
C====================                                                   
      NLIGRD=IPT2.NUM(/1)                                               
      NLIGRP=NLIGRD
      nelrig=ipt2.num(/2)         
      SEGINI XMATR6 
      do 34 i=1,nelrig    
      DO 36 ICAZ=3,IPT2.NUM(/1)
        XMATR6.RE(1,ICAZ,i)=XCOEFF(IDEBUT-3+ICAZ)
        XMATR6.RE(ICAZ,1,i)=XMATR6.RE(1,ICAZ,i)
  36  CONTINUE
      XMATR6.RE(1,2,i)=-1 
      xmatr6.re(2,1,i)=-1 
   34 continue
*C====================                                                  
*C *** SEGMENT IMATRI                                                    
*C====================                                                   
*      NELRIG=IPT2.NUM(/2)                                               
*      SEGINI IMATR6                                                     
*      DO 34 I=1,IMATR6.IMATTT(/1)                                       
*        IMATR6.IMATTT(I)=XMATR6
*  34  CONTINUE                                     
C====================                                                   
C *** SEGMENT DESCR                                                     
C====================                                                   
      NLIGRD=IPT2.NUM(/1)                                               
      NLIGRP=NLIGRD                                                     
      SEGINI DES1                                                       
      NEXIST=0 
      nomid1=lnomid(1)
      segact nomid1                                                      
      DO 33 I=1,LNOMDD                                                  
        IF (NOMDD(I).EQ.nomid1.lesobl(1)) NEXIST = I                           
  33  CONTINUE 
      segdes nomid1                                                         
      IF (NEXIST.EQ.0) RETURN                                           
      DES1.LISINC(1)='LX  '                                             
      DES1.LISDUA(1)='FLX '                                             
      DES1.NOELEP(1)=1
      DES1.NOELED(1)=1
      DO 35 I=2,NLIGRD                                                  
        DES1.LISINC(I)=NOMDD(NEXIST)                                    
        DES1.LISDUA(I)=NOMDU(NEXIST) 
        DES1.NOELEP(i)=i   
        DES1.NOELED(i)=i                                                 
  35  CONTINUE                         
C====================                                                   
C *** SEGMENT MRIGID                                                    
C==================== 
      RI6.ICHOLE=0                                                      
      RI6.IMGEO1=0                                                      
      RI6.IMGEO2=0                                                      
      RI6.IFORIG=0                                                      
      RI6.ISUPEQ=0                                                      
      RI6.COERIG(ia)=1                                                   
      RI6.IRIGEL(1,ia)=IPT2                                              
      RI6.IRIGEL(2,ia)=0                                                 
      RI6.IRIGEL(3,ia)=DES1                                              
      RI6.IRIGEL(4,ia)=xMATR6                                            
      RI6.IRIGEL(5,ia)=0                                                 
      RI6.IRIGEL(6,ia)=0                                                 
      RI6.IRIGEL(7,ia)=0                                                 
      RI6.IRIGEL(8,ia)=0                                         
      enddo
      
       call depen3(ri6,iri1)       
*       call prrigi(iri1,0)
*       write(6,*) ' chpoint initial'
*       call ecchpo (mchpoi,0)
       call mucpri (mchpoi,iri1,mchpo2)
*       write(6,*) ' chpoint apres mucpri'
*       call ecchpo (mchpo2,0) 
       call reduir(mchpoi,ipt1,mchpo3)
*       write(6,*) ' valeurs initiales à reajuster'
*       call ecchpo(mchpo3,0)
       call adchpo (mchpoi,mchpo3,mchpo4,1.d0,-1.d0)
       call adchpo(mchpo4,mchpo2,irat, 1.d0,1.d0)
       if(irat.eq.0) return
*       write(6,*) ' sortie de depcom'
*       call ecchpo(irat,0)
       call ecrobj('CHPOINT',irat)  
      return
      end