C PROBAS    SOURCE    CHAT      09/10/09    21:21:54     6519           
      SUBROUTINE PROBAS(IRIIN,itmod,IRIOUT)
      IMPLICIT REAL*8(a-h,o-z)
      IMPLICIT INTEGER(I-N)
      CHARACTER*4 motinc,motddl
-INC SMCOORD
-INC CCOPTIO
-INC SMTABLE
-INC SMRIGID
-INC SMELEME
      segment icpr(xcoor(/1)/(idim + 1))

      MRIGID = IRIIN
      mtable = itmod
      segact mtable
      im1 = mlotab
      ima = mlotab - 1
* pour chaque noeud implique dans une liason on fait intervenir toutes
* les solutions statiques associées
*
* on les recense donc     
      segini icpr
      do im = 1,ima
         CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',.true.,IP0,
     &                      'TABLE',I1,X1,' ',.true.,ITAB2)
         CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_LIAISON',.true.,IP0,
     &                      'POINT',I1,X1,' ',.true.,IPL1)
         icpr(ipl1) = icpr(ipl1) + 1
      enddo

      KRIGEL = 0 
      segact mrigid
      nrigel = irigel(/2)
      nrige = irigel(/1)
      segini ri1
      ri1.mtymat = mtymat
      nrige0 = nrigel

      kige = 0
      nrigel = kige
      segini ri2
      ri2.mtymat = mtymat

      DO ire = 1,nrige0
        meleme = irigel (1,ire)
        segact meleme
        if (itypel.ne.22) then 
           call erreur(977)
           return
        endif
        nbelem = num(/2)
        nbele0 = nbelem
        descr = irigel(3,ire)
        segact descr
        nligrp0 = noelep(/1)
        nligrd0 = noeled(/1)
        nligrp = nligrp0
        nligrd = nligrp
        segini des1
        des1.lisinc(1) = 'LX'
        des1.lisdua(1) = 'FLX'
        des1.noelep(1) = 1
        des1.noeled(1) = 1
        do ig =2,nligrp
         des1.lisinc(ig) = 'BETA' 
         des1.lisdua(ig) = 'FBET' 
         des1.noelep(ig) = ig
         des1.noeled(ig) = ig
        enddo
        segini,des2=des1

        nbnn = nligrp0
        nbsous = 0
        nbref = 0
        segini ipt2
        ipt2.itypel = itypel
        nbelem = 1
        segini ipt1
        ipt1.itypel = itypel
        ri1.coerig(ire) = coerig(ire)
        kele = 0 

        DO iele = 1,nbele0

* le premier point correspond aux multiplicateurs
          CALL CREPO1 (ZERO, ZERO, ZERO, IPTS)
          ipt1.num(1,1) = ipts
          koel = 1
          do igrp = 2,nligrp0
             jno = noelep(igrp)
             motinc = lisinc(igrp) 
             IP1 = num(jno,iele)
             do im = 1,ima
         CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',.true.,IP0,
     &                      'TABLE',I1,X1,' ',.true.,ITAB2)
         CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_LIAISON',.true.,IP0,
     &                      'POINT',I1,X1,' ',.true.,IPL1)
         CALL ACCTAB(ITAB2,'MOT',I0,X0,'DDL_LIAISON',.true.,IP0,
     &                      'MOT',I1,X1,motddl,.true.,I1)
              if (motinc.eq.motddl.and.IPL1.eq.IP1) then
          CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_REPERE',.true.,IP0,
     &                      'POINT',I1,X1,' ',.true.,IPTS)
            ipt1.num(igrp,1) = ipts
              koel = koel + 1 
               goto 16
              endif
             enddo
c point-liaison et ddl non trouvés
             ipt1.num(igrp,1) = ip1
             des2.lisinc(igrp) = lisinc(igrp) 
             des2.lisdua(igrp) = lisdua(igrp)
             des2.noelep(igrp) = noelep(igrp)
             des2.noeled(igrp) = noeled(igrp)
*
 16          continue
          enddo
*
c creation d'un irigel
          if (koel.ne.nligrp0) then
c           call erreur(978)
c           return
           kige = kige + 1 
           nrigel = kige
           segadj ri2
           segini,ipt3=ipt1
           segini,des3=des2
           RI2.IRIGEL(1,kige) = IPT3
           RI2.IRIGEL(3,kige) = DES3
           RI2.IRIGEL(4,kige) = irigel(4,ire)
           RI2.IRIGEL(2,kige) = 0
           RI2.IRIGEL(5,kige) = irigel(5,ire)
           RI2.IRIGEL(6,kige) = irigel(6,ire)
           ri2.coerig(kige) = coerig(ire)
           do ig =2,nligrp
             des2.lisinc(ig) = 'BETA' 
             des2.lisdua(ig) = 'FBET' 
             des2.noelep(ig) = ig
             des2.noeled(ig) = ig
           enddo
          else
* toutes les inconnues sont des BETA
            kele = kele + 1 
            do ig = 1,nligrp0
             ipt2.num(ig,kele) = ipt1.num(ig,1)
            enddo
          endif
        ENDDO

        nbelem = kele
        if (nbelem.gt.0) then
          segadj ipt2
          krigel = krigel + 1
          RI1.IRIGEL(1,krigel) = IPT2
          RI1.IRIGEL(3,krigel) = DES1
          RI1.IRIGEL(4,krigel) = irigel(4,ire)
          RI1.IRIGEL(2,krigel) = 0
          RI1.IRIGEL(5,krigel) = irigel(5,ire)
          RI1.IRIGEL(6,krigel) = irigel(6,ire)
          segdes des1, ipt2
        else
          segsup des1, ipt2
        endif
        segsup ipt1
       ENDDO

        iriout = 0
        nrigel = krigel
        segadj ri1 
c        write(6,*) 'ri1', ri1.irigel(/2), ' ri2',ri2.irigel(/2)
        segdes mrigid,ri1,mtable,ri2
       if (kige.eq.0) segsup ri2
       if (krigel.eq.0) segsup ri1
       if (kige.gt.0.and.krigel.gt.0) then
c        write(6,*) 'fus', ri1,ri2,kige,krigel
         call fusrig(ri1,ri2,iriout)
         segsup ri1, ri2
         return
       endif
       if (kige.gt.0) iriout = ri2 
       if (krigel.gt.0) iriout = ri1 
       if (iriout.eq.0) call erreur(-5)
       return
       END