C RELABA    SOURCE    PV090527  26/04/30    21:16:08     12529          
      SUBROUTINE RELABA
*
* relation barycentrique pour les ddl d'un noeud vis-à-vis
* d'un maillage
*  rig1 = rela bary lmot1 (ou 'DEPL' ou 'ROTA') p1 geo1
*
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMCOORD
-INC SMRIGID
-INC CCHAMP
-INC SMLREEL
-INC SMLMOTS
c
      CHARACTER*4 ITCORI(2),LEMOT,LESDDL(6),LESDUA(6)
      CHARACTER*4 MODEPL(5),MODEDU(5),MOROTA(5),MORODU(5)
      DATA ITCORI(1)/'DEPL'/
      DATA ITCORI(2)/'ROTA'/
      DATA MODEPL / 'UX  ','UY  ','UZ  ','UR  ','UT  ' /
      DATA MODEDU / 'FX  ','FY  ','FZ  ','FR  ','FT  ' /
      DATA MOROTA / 'RX  ','RY  ','RZ  ','RT  ','RS  ' /
      DATA MORODU / 'MX  ','MY  ','MZ  ','MT  ','MS  ' /

      CALL LIROBJ('LISTMOTS',IP0,0,IRETOU)

      if (IP0.eq.0) then
         CALL LIRMOT(ITCORI,2,IMOT,0)
         if (imot.eq.0) then
          call erreur(5)
          return
         else if (imot.eq.1) then
          if (ifour.eq.2) then
           nosddl = 3
           lesddl(1) = modepl(1)
           lesddl(2) = modepl(2)
           lesddl(3) = modepl(3)
          else
          endif
           CALL LIRMOT(ITCORI,2,IMOT,0)
           if (imot.eq.2) then
            if (ifour.eq.2) then
             nosddl = 6
             lesddl(4) = morota(1)
             lesddl(5) = morota(2)
             lesddl(6) = morota(3)
            else
            endif
           endif
         else
           CALL LIRMOT(ITCORI,2,IMOT,0)
           if (imot.eq.1) then
            if (ifour.eq.2) then
             nosddl = 6
             iddl = 3
            else
            endif
           else
            if (ifour.eq.2) then
             nosddl = 3
             iddl = 0
            else
            endif

           endif
           if (ifour.eq.2) then
            lesddl(iddl + 1) = morota(1)
            lesddl(iddl + 2) = morota(2)
            lesddl(iddl + 3) = morota(3)
          else
          endif
        endif
      else
       mlmots = ip0
       segact mlmots
       jgn = mots(/2)
       do 11 imo = 1,jgn
        do jde =1,5
         if (mots(imo).eq.modepl(jde)) then
           lesddl(imo) = modepl(jde)
           lesdua(imo) = modedu(jde)
           goto 11
         endif
        enddo
        do jde = 1,5
         if (mots(imo).eq.morota(jde)) then
           lesddl(imo) = morota(jde)
           lesdua(imo) = morodu(jde)
           goto 11
         endif
        enddo
c le mot  n est pas un ddl
        call erreur(5)
        return
 11    continue
       nosddl = jgn
      endif


      CALL LIROBJ('POINT',IP1,1,IRETOU)
      CALL LIROBJ('MAILLAGE',IP2,1,IRETOU)
      meleme = ip2
      segact meleme
      if (itypel.ne.1) call change(ip2,1)
      meleme = ip2
      segact meleme
      nbele1 = num(/2)
      ipt1 = ip2
      CALL LIROBJ('LISTREEL',IP3,0,IRETOU)
      if (iretou.eq.1) then
       mlreel = ip3
       segact mlreel
       jg = prog(/1)
       if (jg.ne.nbele1) then
c autant de coef que de points
         call erreur(5)
         return
       endif
       som1 = prog(1)
       do j = 2,jg
         som1 = som1 + prog(j)
       enddo
       if (som1.eq.0.D0) then
c somme des coefs nulle
         call erreur(5)
         return
       endif
      else
       jg = 1
      endif


* cree multiplicateur(s)
      segact mcoord*mod
      NBPTI=nbpts
      NBPTS = NBPTI + nosddl
      segadj mcoord
      do j = 1,nosddl
       xcoor((nbpti - 1 + j)*(idim + 1) + 1) = 0.d0
       xcoor((nbpti - 1 + j)*(idim + 1) + 2) = 0.d0
       if (idim.eq.3) xcoor((nbpti - 1 + j)*(idim + 1) + 3) = 0.d0
       xcoor((nbpti + j)*(idim + 1)) = 0.d0
      enddo

* cree rigidite
      NRIGE = 6
      NRIGEL = nosddl
      segini mrigid
      ICHOLE=0
      IMGEO1=0
      IMGEO2=0
      ISUPEQ=0
      IFORIG=IFOUR
      MTYMAT='RIGIDITE'

       NLIGRP=nbele1 + 2
       NLIGRD=nbele1 + 2
           nelrig=1
       rigrel=0
       segini xmatri
*       nelrig = 1
*       segini imatri
*       imattt(1) = xmatri
       re(1,1,1) = 0.d0
       if (jg.eq.1) then
         re(1,2,1) = 1.D0/nbele1
         re(2,1,1) = re(1,2,1)
         do l = 1, nbele1
          re(1,2 + l,1) = -1.D0
          re(2+l,1,1) = -1.D0
         enddo
       else
         re(1,2,1) = 1.D0/som1
         re(2,1,1) = re(1,2,1)
         do l = 1, nbele1
          re(1,2 + l,1) = -1.D0*prog(l)
          re(2+l,1,1) = re(1,2+l,1)
         enddo
       endif
       segdes xmatri

      do ir = 1,nosddl
        ipmu = NBPTI + ir
        nbnn = nbele1 + 2
        nbelem = 1
        nbsous = 0
        nbref = 0
        segini meleme
        itypel = 22
        num(1,1) = ipmu
        num(2,1) = ip1
        segact ipt1
        do in = 1,nbele1
          num(2+in,1) = ipt1.num(1,in)
        enddo
        icolor(1) = idcoul
        segdes meleme

       SEGINI DESCR
       NOELEP(1)= 1
       NOELED(1)= 1
       LISINC(1)='LX'
       LISDUA(1)='FLX'
       do l = 1,nbele1+1
         LISINC(1 + l)=lesddl(ir)
         LISDUA(1 + l)=lesdua(ir)
         NOELEP(1+l)= 1 + l
         NOELED(1+l)= 1 + l
       enddo
       SEGDES DESCR

        coerig(ir) = 1.d0
        IRIGEL(2,ir) = 0
        IRIGEL(5,ir) = NIFOUR
        IRIGEL(6,ir) = 0
        IRIGEL(1,ir) = meleme
        IRIGEL(3,ir) = descr
        IRIGEL(4,ir) = xmatri


      enddo
      segdes mrigid

      CALL ECROBJ('RIGIDITE',mrigid)
      RETURN
      END