C HATRIG    SOURCE    PV        17/12/05    21:16:25     9646           
      SUBROUTINE HATRIG (ICOLAC)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C-----------------------------------------------------------------------
C
C   BUT  :VA A LA PECHE DES CHAPEAUX DES OBJETS RIGIDITES
C         DEJA CONTENUS DANS LES PILES
C LOGIQUE:
C       ON SE POINTE SUR LA PILE
C       ON CREE LA TABLE DES OBJETS DU TYPE DE CETTE PILE
C--    CAS GENERAL
C       ON TESTE SI LE POINTEUR DANS L OBJET EST DANS LA PILE
C       SI OUI, ON PASSE A  L OBJET SUIVANT.
C       SI NON
C
C
C       SI L ENSEMBLE DES POINTEURS EST CONTENU DANS LE ITLAC ASSOCIE
C       ALORS ON RAJOUTE L OBJET DANS LA PILE , CE QUI OBLIGE A UN
C       RAPPEL DE FILLPI
C
C   PROGRAMME PAR :  FARVACQUE-REPRIS PAR LENA
C   APPELE PAR    :  SAUV
C   APPELLE       :     SORT7   SORT8  ERREUR  REPERT
C
C=======================================================================
C  TABLEAU KCOLA :
C    1  MELEME  2 CHPOIN  3 MRIGID  4 MCHAFF  5 MCHELM  6 MCLSTR
C    7  MELSTR  8 MSOLUT  9 MSTRUC 10        11 MAFFEC 12 MSOSTU
C   13  IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL
C   19  MLENTI 20 MCHARG 21 MODELE 22 MEVOLL
C=======================================================================
C
-INC SMRIGID

-INC PPARAM
-INC CCOPTIO
-INC TMCOLAC
      SEGMENT ILISBB
         INTEGER ILISOB(MLON)
      ENDSEGMENT
      DIMENSION IBID(1)
C
      CHARACTER*(8) ITYPE
C
      SEGACT ICOLAC
      ILISSE=ILISSG
      SEGACT ILISSE*MOD
C
C
C     **************************** MRIGID ******************************
C
      IFILE=0
      ITYPE='RIGIDITE'
      CALL TYPFIL (ITYPE,IFILE)
      ITLACC=KCOLA(IFILE)
      IMAX1=ITLAC(/1)
      IF(IMAX1.EQ.0) GO TO 600
      CALL LISTOB(ITYPE,MLON,IBID,0)
      SEGINI ILISBB
      CALL LISTOB(ITYPE,N,ILISOB,1)
C     LA PILE N EST PAS VIDE-------------------------------
C      CALL REPERT (ITYPE,N)
      IF (N.EQ.0) GO TO 599
      ITLAC1=KCOLA(1)
      ITLAC2=KCOLA(11)
      ITLAC3=KCOLA(13)
C
      DO 1500 I   =1,N
      MRIGID = ILISOB(I)
C      CALL LIROBJ(ITYPE,MRIGID,1,IRETOU)
      CALL SNOM2(MRIGID,ITLACC,IRET)
      IF(IRET.NE.0) GOTO 1500
C --- ON RECHERCHE PLUS PROFONDEMENT
      SEGACT MRIGID
      NRIGEL=IRIGEL(/2)
      DO 1501 IR=1,NRIGEL
      DO 1502 J=1,IMAX1
      RI1=ITLAC(J)
      if(ri1.eq.0) goto 1502
      SEGACT RI1
      NRIGE1=RI1.IRIGEL(/2)
      DO 1503 K=1,NRIGE1
C     KK=ITLAC1.ITLAC(RI1.IRIGEL(1,K))
C     IF(IRIGEL(1,IR).NE.KK) GOTO 1503
C     IF(RI1.IRIGEL(2,K).EQ.0) THEN
C         KK=0
C       ELSE
C         KK=ITLAC2.ITLAC(RI1.IRIGEL(2,K))
C     ENDIF
C     IF(IRIGEL(2,IR).NE.KK) GOTO 1503
C     KK=ITLAC3.ITLAC(RI1.IRIGEL(4,K))
C     IF(IRIGEL(4,IR).NE.KK) GOTO 1503
      IF(IRIGEL(4,IR).NE.RI1.IRIGEL(4,K)) GOTO 1503
      SEGDES RI1
      GOTO 1501
 1503 CONTINUE
      SEGDES RI1
 1502 CONTINUE
      SEGDES MRIGID
      GOTO 1500
 1501 CONTINUE
      SEGDES MRIGID
      CALL AJOUN (ITLACC,MRIGID,ILISSE,1)
 1500 CONTINUE
  599 CONTINUE
      SEGSUP ILISBB
  600 CONTINUE
*      SEGDES ICOLAC,ILISSE
      RETURN
      END