C PROBAS    SOURCE    FANDEUR   22/03/01    21:15:06     11301          
      SUBROUTINE PROBAS(IRIIN,itmod,IRIOUT)
      IMPLICIT REAL*8(a-h,o-z)
      IMPLICIT INTEGER(I-N)

-INC PPARAM
-INC CCOPTIO

-INC SMCOORD
-INC SMTABLE
-INC SMRIGID
-INC SMELEME
      PARAMETER(ZERO=0.D0)
      segment icpr(nbpts)

      CHARACTER*(LOCHPO) motinc,motddl
      CHARACTER*8 TYPRET,TYPMOT,TYPENT
      CHARACTER*(32) motbid
      LOGICAL bool

      bool = .TRUE.
      I0 = 0
      I1 = 0
      X0 = ZERO
      X1 = ZERO
      TYPMOT = 'MOT     '
      TYPENT = 'ENTIER  '
      motbid = ' '
      IP0 = 0
      IP1 = 0

      MRIGID = IRIIN
      mtable = itmod
      segact mtable
      im1 = mlotab - 1
      ima = im1
* pour chaque noeud implique dans une liaison on fait intervenir toutes
* les solutions statiques associées
* on les recense donc
      segini icpr
      do im = 1,im1
         TYPRET = ' '
         ITAB2  = 0
         CALL ACCTAB(ITMOD,TYPENT,IM,X0,motbid,bool,IP0  ,
     &                     TYPRET,I1,X1,motbid,bool,ITAB2)
         IF(IERR.NE.0) RETURN
         IF (TYPRET.NE.'TABLE   ' .OR.ITAB2.LE.0) THEN
           ima = im - 1
           GOTO 1
         ENDIF
         TYPRET = 'POINT   '
         motbid = 'POINT_LIAISON'
         CALL ACCTAB(ITAB2,TYPMOT,I0,X0,motbid(1:13),bool,IP0 ,
     &                     TYPRET,I1,X1,motbid      ,bool,IPL1)
         IF(IERR.NE.0) RETURN
         icpr(IPL1) = icpr(IPL1) + 1
      enddo
 1    CONTINUE

      segact mrigid
c*      nrige = irigel(/1)
      nrige0 = irigel(/2)

      nrigel = nrige0
      segini ri1
      ri1.mtymat = mtymat
      ri1.iforig = iforig

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

      krigel = 0
      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

          X0 = ZERO
* le premier point correspond aux multiplicateurs
          CALL CREPO1 (X0, X0, X0, 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
              TYPRET = 'TABLE   '
              motbid = ' '
              CALL ACCTAB(ITMOD,TYPENT,IM,X0,motbid,bool,IP0  ,
     &                          TYPRET,I1,X1,motbid,bool,ITAB2)
              IF (IERR.NE.0) RETURN
              TYPRET = 'POINT   '
              motbid = 'POINT_LIAISON'
              CALL ACCTAB(ITAB2,TYPMOT,I0,X0,motbid( 1:13),bool,IP0,
     &                          TYPRET,I1,X1,motbid(14:32),bool,IPL1)
              IF (IERR.NE.0) RETURN
              motbid = 'DDL_LIAISON'
              CALL ACCTAB(ITAB2,TYPMOT,I0,X0,motbid(1:11),bool,IP0,
     &                          TYPMOT,I1,X1,motddl      ,bool,I1 )
              IF (IERR.NE.0) RETURN
              if (motinc.eq.motddl.and.IPL1.eq.IP1) then
                TYPRET = 'POINT   '
                motbid = 'POINT_REPERE'
                CALL ACCTAB(ITAB2,TYPMOT,I0,X0,motbid( 1:12),bool, IP0,
     &                            TYPRET,I1,X1,motbid(13:32),bool,IPTS)
                IF (IERR.NE.0) RETURN
            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.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)
       if (kige.eq.0) segsup ri2
       if (krigel.eq.0) segsup ri1

c       return
       END