C REDU      SOURCE    CHAT      12/01/17    21:15:55     7248           
      SUBROUTINE REDU
*_______________________________________________________________________
*
*   sous routine de l'operateur redu qui aiguille suivant la fonctionnalite
*
*_______________________________________________________________________
*
* declaration
*
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC SMELEME
-INC SMNUAGE
-INC SMLMOTS
-INC SMTABLE
-INC SMCHAML
*
       INTEGER I,NCOMP,J,IPO,INUA
       CHARACTER*4 IMO,charre
       LOGICAL logr1
       CHARACTER*8 TYPOBJ
      character*4 mostri(1)
      data mostri/'STRI'/
*
* executable
*
*
*    a-t'on en entrée une table esclave si oui on fusionne
*
*  a-t'on le mot strict?
       istric=0
       call lirmot(mostri,1,istric,0)
*
       call lirtab('ESCLAVE',mtable,0,iretou)
       if(iretou.ne. 0) then
*         write(6,*) ' on fusionne la table esclave'
         typobj=' '
         segact mtable
         ml=mlotab
         ind=mtabii(2)
      call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre,
     >    xvalre,charre,logr1,id1)
        if (ierr.ne.0) return
*        if (typobj.eq.'CHPOINT'.or.typobj.eq.'MCHAML')then
         if (typobj.eq.'MCHAML')then
          do i=3,ml
            segact mtable
            ind=mtabii(i)
       call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre,
     >      xvalre,charre,logr1,id2)
            if (ierr.ne.0) return
*            if (typobj.eq.'CHPOINT') call fuchpo(id1,id2,iretou)
            if (typobj.eq.'MCHAML') call fuschl(id1,id2,iretou)
            id1=iretou 
          enddo
        else
          write (6,*) ' type ',typobj,' inconnu dans redu   '
          call trbac
          call erreur(5)
        endif
        CALL ECROBJ(typobj,id1)
*        write(6,*)'  on a crée un objet ' , typobj 
      endif
       
*
* reduction d'une rigidite sur un maillage
*     
      CALL LIROBJ('RIGIDITE',IPrigi,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 10
      CALL LIROBJ('MAILLAGE',IMEL,1,IRETOU)
      IF(IRETOU.EQ.0) return
      call reduri(iprigi,imel,irig1)
      if(irig1.eq.0) return
       call ecrobj('RIGIDITE', irig1)
       return      
  10  CONTINUE           
*
*     redu d'un chpoint sur (meleme ou  point)
*
      CALL LIROBJ('CHPOINT ',ICHP,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 1
      CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
         CALL LIROBJ('POINT',IP1,0,IRETOU)
         IF (IRETOU.NE.0) THEN
            NBNN=1
            NBELEM=1
            NBREF=0
            NBSOUS=0
            SEGINI MELEME
            ITYPEL=1
            NUM(1,1)=IP1
            SEGDES MELEME
            IMEL=MELEME
         ELSE
            CALL REFUS
            GO TO 1
         ENDIF
      ENDIF
      CALL REDUIR(ICHP,IMEL,IRET)
      IF ( IERR .NE. 0) RETURN
      CALL ECROBJ('CHPOINT',IRET)
      RETURN
*
   1  CONTINUE
*
*     redu mchaml sur meleme (ou point)
*
      CALL LIROBJ('MCHAML',ICHE,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 2
      CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
         CALL LIROBJ('POINT',IP1,0,IRETOU)
         IF (IRETOU.NE.0) THEN
            NBNN=1
            NBELEM=1
            NBREF=0
            NBSOUS=0
            SEGINI MELEME
            ITYPEL=1
            NUM(1,1)=IP1
            SEGDES MELEME
            IMEL=MELEME
         ELSE
            CALL REFUS
            GOTO 2
         ENDIF
      ENDIF
      CALL REDUIC(ICHE,IMEL,IRET)
      IF ( IERR .NE. 0) RETURN
      CALL ECROBJ('MCHAML',IRET)
      RETURN
*
   2  CONTINUE
*
*     redu  chamelem sur mmodel
*
      CALL LIROBJ('MCHAML',ICHE,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 3
      CALL LIROBJ('MMODEL',IPMODL,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 3
       ENDIF
       CALL REDUAF(ICHE,IPMODL,IPCHM,ISTRIC,IRET,KERRE)
       IF ( IRET .NE. 1) THEN
         CALL ERREUR(KERRE)
         RETURN
       ENDIF
* segdes de l'entree
       mchelm=iche
       segact mchelm
       do j=1,ichaml(/1)
        mchaml=ichaml(j)
        segact mchaml
        do k=1,ielval(/1)
         melval=ielval(k)
         segdes melval
        enddo
        segdes mchaml
       enddo
       segdes mchelm
*  segdes du resultat
       mchelm=ipchm
       segact mchelm
       do j=1,ichaml(/1)
        mchaml=ichaml(j)
        segact mchaml
        do k=1,ielval(/1)
         melval=ielval(k)
         segdes melval
        enddo
        segdes mchaml
       enddo
       segdes mchelm
*
       CALL ECROBJ('MCHAML',IPCHM)
       RETURN
*
   3  CONTINUE
*
*     redu chpoint sur masq
*
      CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 4
      CALL LIROBJ('CHPOINT',ICHP1,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
         CALL REFUS
         GO TO 4
      ENDIF
      CALL REDUCP(ICHP,ICHP1,IRET)
      IF(IERR.NE.0) RETURN
      CALL ECROBJ('CHPOINT',IRET)
      RETURN
*
   4  CONTINUE
*
*     redu mmodel sur meleme ou point ou reduit le model de contatct
* au element qui peuvent etre actifs
*
      CALL LIROBJ('MMODEL',IPMODL,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 5
      CALL LIRCHA(charre,0,ireto)
      if(ireto.ne.0) then
        if( charre.ne.'CONT' ) then
          call refus
        else
          call redcon(ipmodl,iret)
          call ecrobj('MMODEL',iret)
          return
        endif
      endif
      CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
         CALL LIROBJ('POINT',IP1,0,IRETOU)
         IF (IRETOU.NE.0) THEN
            NBNN=1
            NBELEM=1
            NBREF=0
            NBSOUS=0
            SEGINI MELEME
            ITYPEL=1
            NUM(1,1)=IP1
            SEGDES MELEME
            IMEL=MELEME
         ELSE
            CALL REFUS
            GOTO 5
         ENDIF
      ENDIF
      CALL REDUMO(IPMODL,IMEL,IRET)
      IF (IRET.NE.0) THEN
         CALL ECROBJ('MMODEL',IRET)
      ENDIF
      RETURN
*
   5  CONTINUE
*
*    redu d'un nuage a des composantes
*
      CALL LIRCHA(IMO,1,IRETOU)
          IF (IRETOU.NE.0) THEN
           JGN = 4
           JGM = 10
           SEGINI MLMOTS
              MOTS(1) = IMO
              IPO1 = MLMOTS
          ENDIF
       DO 100 I = 2,100
         CALL LIRCHA(IMO,0,IRETOU)
             IF (IRETOU.NE.0) THEN
                MOTS(I) = IMO
                   IF (I.GT.10) THEN
                     JGM = I
                     SEGADJ MLMOTS
                     MOTS(I) = IMO
                     IPO1 = MLMOTS
                   ENDIF
                NCOMP = I
             ELSE
                NCOMP = I - 1
             GOTO 101
             ENDIF
  100     CONTINUE
  101     CONTINUE
       DO 200 I = 1,NCOMP
       DO 201 J = (I + 1),NCOMP
           IF (MOTS(I).EQ.MOTS(J)) THEN
              CALL ERREUR(674)
              RETURN
           ENDIF
  201     CONTINUE
  200     CONTINUE
      CALL LIROBJ('NUAGE',INUA,1,IRETOU)
           MNUAG1 = INUA
      IF (IRETOU.EQ.0) GOTO 6
             CALL REDNUA(INUA,IPO1,NCOMP,INUAR,IRET)
          IF (IRET.NE.0) THEN
             CALL ECROBJ('NUAGE',INUAR)
          ENDIF
          SEGDES MLMOTS
       RETURN
*
  6      CONTINUE
c
c    pas d operande correcte trouve
c
      CALL QUETYP(MOTERR(1:8),0,IRETOU)
      IF(IRETOU.NE.0) THEN
         CALL ERREUR (39)
      ELSE
         CALL ERREUR(533)
      ENDIF

      RETURN
      END