C EVREC6    SOURCE    CHAT      11/03/16    21:21:27     6902           
      SUBROUTINE EVREC6(itap,ipmode,ipcha1,mcha,nomco,ctype,iptu,ipevo)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCOPTIO 
-INC SMEVOLL  
-INC SMCHPOI
-INC SMELEME
-INC SMMODEL
-INC SMTABLE
-INC SMCHAML
-INC SMLENTI
-INC SMLREEL
      LOGICAL L0,LVAR,dix
      CHARACTER*8 CTYPE,ITYP1,CTYP,TYPRET,CHARRE
      CHARACTER*72 TI,MCHA,NOMCO
      CHARACTER*4 CMOT                                                          
      

      TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'TEMPS',           
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IPTEM)

      if (mcha(1:4).eq.'DEPL') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'DEPLACEMENTS',           
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else if (mcha(1:4).eq.'VITE') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'VITESSES',           
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else if  (mcha(1:4).eq.'ACCE') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'ACCELERATIONS',           
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else if  (mcha(1:4).eq.'REAC') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'REACTIONS',           
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else if  (mcha(1:4).eq.'CONT') then
        TYPRET = ' '
      CALL ACCTAB(ITAP,'MOT',I0,X0,'CONTRAINTES',           
     &                 L0,IP0,TYPRET,I1,X1,CHARRE,LVAR,IP1)
      else 
      endif

      IPX=0                                                                     
      ITOUS=0                                                                   
      ILX=0
      dix = .false.                                                                     
      CALL LIROBJ('LISTREEL',IPX,0,IRETOU)                                      
      IF(IRETOU.EQ.0) CALL LIROBJ('LISTENTI',ILX,0,IRETOU)                      
      IF(IRETOU.EQ.0) dix = .true.                                                   
      if (ilx.gt.0) then
        mlent3 = ilx
        segact mlent3
      endif
      if (ipx.gt.0) then
        mlree3 =ipx
        segact mlree3
      endif
      kix = 1

      call dimen7(iptem, ntemps) 
       CALL ACCTAB(IPTEM,'ENTIER',(ntemps - 1),X0,ITYP1,           
     &                 L0,IP0,'FLOTTANT',I1,XTM,CHARRE,LVAR,IP2)
      if (dix) then
        jg = ntemps
      else if (ipx.gt.0) then
        jg = mlree3.prog(/1)
      elseif (ilx.gt.0) then
        jg = mlent3.lect(/1)
      endif 
      segini mlree1
        jg0 = jg

      IF (CTYPE.EQ.'POINT   ') THEN                                             
         JG=1
         N = JG                                                                   
         SEGINI MLENTI,mlent1                                                           
         LECT(1)=IPTU                                                       
         jg = jg0
         segini mlreel
         mlent1.lect(1) = mlreel
*                                                                               
      ELSE IF (CTYPE.EQ.'MAILLAGE') THEN                                        
         MELEME= IPTU                                                           
         SEGACT MELEME                                                          
         IF(ITYPEL.NE.1) CALL CHANGE (IRET,1) 
         segdes meleme                                  
         MELEME=IRET                                                            
         SEGACT MELEME                                                          
         JG=NUM(/2)
         N = JG                                                              
         SEGINI MLENTI,mlent1                                                           
         DO 10 I=1,JG                                                            
            LECT(I)=NUM(1,I)                                                      
            jg = jg0
            segini mlreel
            mlent1.lect(i) = mlreel
 10      CONTINUE
         SEGSUP MELEME  
      ELSE
* cas vits
       call erreur(5)
      ENDIF

      kite = 0
      do ite = 0,(ntemps - 1)
       if (ilx.gt.0) then
        do jko = kix, mlent3.lect(/1)
         if (mlent3.lect(jko).eq.ite) then
           kix = jko
           dix = .true.
           goto 30
         endif
        enddo
       endif
       CALL ACCTAB(IPTEM,'ENTIER',ite,X0,ITYP1,           
     &                 L0,IP0,'FLOTTANT',I1,XT1,CHARRE,LVAR,IP2)
       if (ipx.gt.0) then
        if (kix.le.mlree3.prog(/1)) then
        do jko = kix, mlree3.prog(/1)
c         write(6,*) mlree3.prog(jko), xt1, 1.e-6*xtm,
c     &(dabs(mlree3.prog(jko) - xt1).le.1.e-6*xtm) 
         if (dabs(mlree3.prog(jko) - xt1).le.1.e-6*xtm) then
           kix = jko + 1
           dix = .true.
           goto 30
         endif
        enddo
        endif
       endif

 30    if (dix) then
         kite = kite + 1
       CALL ACCTAB(IP1,'ENTIER',ite,X0,ITYP1,           
     &                 L0,IP0,'CHPOINT',I1,X1,CHARRE,LVAR,IPCH1)
* recombinaison
       call recof2(ipmode,ipcha1,ipch1,ipch2)

        DO 41 IP=1,lect(/1)
          mpoint=lect(ip)
          CMOT=nomco(1:4)
          call EXTRA9(IPCH2,MPOINT,cmot,KERRE,XFLOT)
          mlreel = mlent1.lect(ip)
          prog(kite)=xflot
  41    continue

       mchpo2 = ipch2
       segsup mchpo2

         mlree1.prog(kite) = XT1
       endif
       if (ipx.gt.0.or.ilx.gt.0) dix = .false.
      enddo      

      if (kite.gt.0) then
      segini mevoll
      ipevo = mevoll
      ityevo = 'REEL'
      ievtex(1:14) = 'RECOMBINAISON '
      ievtex(15:23) = nomco(1:8)
      do jv = 1,N
        segini kevoll
        ievoll(jv) = kevoll
        iprogx = mlree1
        iprogy = mlent1.lect(jv)
        numevx = jv
        typx = 'LISTREEL'
        typy=  'LISTREEL'
        nomevx = 'TEMPS'
        nomevy = nomco(1:12) 
        segdes kevoll

      enddo
      segdes mevoll
      else
       ipevo = 0
      endif

      RETURN
      END