C CFND      SOURCE    PV090527  26/04/30    21:15:14     12529          
      subroutine cfnd

      implicit real*8(a-h,o-z)
      implicit integer (i-n)
* rendre un chpoint compatible avec des relations de conformités


-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC CCHAMP

-INC SMMODEL
-INC SMELEME
-INC SMCHPOI
-INC SMRIGID
-INC SMCOORD

      logical ltelq
* Petit tableau des "couleurs" des relations de conformite
      DIMENSION LCOLOR(6)
      DATA LCOLOR / 1, 3, 6, 10, 16, 24 /

      call LIROBJ('MMODEL  ',mmodel,1,iretou)
      call ACTOBJ('MMODEL  ',mmodel,1)
      if(ierr.ne.0) return
      call LIROBJ('CHPOINT ',mchpoi,1,iretou)
      call ACTOBJ('CHPOINT ',mchpoi,1)
      if(ierr.ne.0) return

      nmsous = kmodel(/1)
      ncofo = 0
      do ia = 1, nmsous
        imodel=kmodel(ia)
        if (nefmod.eq.22) ncofo = ncofo+1
        if (nefmod.eq.259) ncofo = ncofo+1
      enddo
      if (ncofo.eq.0) then
        segini,mchpo1=mchpoi
        irat = mchpo1
        goto 100
      endif
*
*   il existe des relations de conformités
*
* verif le chpoint n'a qu'une seule zone
      if (ipchp(/1).ne.1) then
        call erreur (21)
        return
      endif
*
* on fabrique les matrices de liaisons et un maillage contenant
* les noeuds dépendants
      nrigel = ncofo
      segini,RI6
      RI6.ICHOLE=0
      RI6.IMGEO1=0
      RI6.IMGEO2=0
c*      RI6.IFORIG=0
c*      RI6.IFORIG=IFOUR
      RI6.IFORIG=mchpoi.ifopoi
      RI6.ISUPEQ=0

      nbnn   = 1
      nbsous = 0
      nbref  = 0
      ltelq=.false.

      ncofo = 0
      do ia = 1, nmsous
        imodel=kmodel(ia)
        if ((nefmod.ne.22).AND.(nefmod.NE.259)) goto 90
        ncofo = ncofo+1

        ipt2=imamod
        nbnoe2 = ipt2.num(/1)
        nbele2 = ipt2.num(/2)

        nbelem = nbele2
        segini,meleme
        do ib = 1, nbelem
          num(1,ib) = ipt2.num(2,ib)
        enddo
        IDEBUT = LCOLOR(ipt2.icolor(1)) - 3

        if (ncofo.eq.1) then
          ipt1=meleme
        else
          call fuse (ipt1,meleme,ipt3,ltelq)
          ipt1=ipt3
        endif

C====================
C *** SEGMENT XMATRI
C====================
        NLIGRD = nbnoe2
        NLIGRP = nbnoe2
        nelrig = nbele2
        rigrel=0
        SEGINI XMATR6
        do 34 i = 1,nelrig
          DO 36 ICAZ = 3, nbnoe2
            XMATR6.RE(1,ICAZ,i) = XCOEFF(IDEBUT+ICAZ)
            XMATR6.RE(ICAZ,1,i) = XMATR6.RE(1,ICAZ,i)
  36      CONTINUE
          XMATR6.RE(1,2,i)=-1.D0
          XMATR6.RE(2,1,i)=-1.D0
   34   continue
        SEGDES,XMATR6
C====================
C *** SEGMENT DESCR
C====================
        nomid=lnomid(1)
        NEXIST = 0
        DO 33 I=1, LNOMDD
          IF (NOMDD(I).EQ.nomid.lesobl(1)) NEXIST = I
  33    CONTINUE
        IF (NEXIST.EQ.0) THEN
          CALL ERREUR(837)
          RETURN
        ENDIF
c*        NLIGRD=nbnoe2
c*        NLIGRP=NLIGRD
        SEGINI,DES1
        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
        SEGDES,DES1
C====================
C *** SEGMENT MRIGID
C====================
        RI6.COERIG(ncofo)=1.D0
        RI6.IRIGEL(1,ncofo)=IPT2
*        RI6.IRIGEL(2,ncofo)=0
        RI6.IRIGEL(3,ncofo)=DES1
        RI6.IRIGEL(4,ncofo)=xMATR6
*        RI6.IRIGEL(5,ncofo)=0
*        RI6.IRIGEL(6,ncofo)=0
*        RI6.IRIGEL(7,ncofo)=0
*        RI6.IRIGEL(8,ncofo)=0

 90     continue

      enddo

      call depen3(ri6,ri1)
*       call prrigi(ri1,0)
*       write(ioimp,*) ' chpoint initial'
*       call ecchpo (mchpoi,0)
      call mucpri (mchpoi,ri1,mchpo2)
*       write(ioimp,*) ' chpoint apres mucpri'
*       call ecchpo (mchpo2,0)
      call reduir(mchpoi,ipt1,mchpo3)
*       write(ioimp,*) ' valeurs initiales à reajuster'
*       call ecchpo(mchpo3,0)
      call adchpo(mchpoi,mchpo3,mchpo4,1.d0,-1.d0)
      if (mchpo4.eq.0) return
      call adchpo(mchpo4,mchpo2,irat, 1.d0,1.d0)
      if (irat.eq.0) return
*       write(ioimp,*) ' sortie de cfnd'
*       call ecchpo(irat,0)
      segsup,ipt1
      segsup,ri6,ri1

 100  continue

      call ACTOBJ('CHPOINT ',irat,1)
      call ECROBJ('CHPOINT ',irat)

      end