C REDUIR    SOURCE    CHAT      05/01/13    02:47:35     5004           
      SUBROUTINE REDUIR(ICHP,IMEL,IRET)                                         
C ======================================================================        
C REDUIT LE CHPOINT ICHP AUX POINTS CONTENUS DANS LE MELEME IMEL.LE             
C RESULTAT IRET EST UN MELEME.                                                  
C ATTENTION : ON A DUPLIQUE LA GEOMETRIE ET LE MPOVAL DANS TOUS LES CAS         
C=======================================================================        
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO                                                                    
-INC SMCHPOI                                                                    
-INC SMELEME                                                                    
-INC SMCOORD                                                                    
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))                                          
      SEGMENT/ITRAV/(ITRAV1(NNOE),ITRAV2(NSOUP))                                
      SEGINI ICPR                                                               
      IRET=0                                                                    
      MELEME=IMEL                                                               
      SEGACT MELEME                                                             
      IKI=0                                                                     
      NBSOUS=LISOUS(/1)                                                         
      IPT1=MELEME                                                               
      DO 4 ISOU=1,MAX(1,NBSOUS)                                                 
       IF (NBSOUS.NE.0) THEN                                                    
       IPT1=LISOUS(ISOU)                                                        
       SEGACT IPT1                                                              
      ENDIF                                                                     
      NBNN=IPT1.NUM(/1)                                                         
      NBELEM=IPT1.NUM(/2)                                                       
      DO 6 I1=1,NBELEM                                                          
      DO 7 I2=1,NBNN                                                            
      IP1=IPT1.NUM(I2,I1)                                                       
      IF(ICPR(IP1).NE.0) GO TO 7                                                
      IKI=IKI+1                                                                 
      ICPR(IP1)=IKI                                                             
 7    CONTINUE                                                                  
 6    CONTINUE                                                                  
      IF(NBSOUS.NE.0) SEGDES IPT1                                               
 4    CONTINUE                                                                  
      SEGDES MELEME                                                             
      NNOE=IKI                                                                  
C                                                                               
      MCHPOI=ICHP                                                               
      SEGACT MCHPOI                                                             
      NSOUP=IPCHP(/1)                                                           
      NSOUPO=0                                                                  
      NBNN=1                                                                    
      NBSOUS=0                                                                  
      NBREF=0                                                                   
      SEGINI ITRAV                                                              
      DO 1 ISOU=1,NSOUP                                                         
      NBELEM=0                                                                  
      MSOUPO=IPCHP(ISOU)                                                        
      SEGACT MSOUPO                                                             
      MELEME=IGEOC                                                              
      SEGACT MELEME                                                             
      N2=NUM(/2)                                                                
      DO 2 I=1,N2                                                               
      IF(ICPR(NUM(1,I)).EQ.0) GO TO 2                                           
      NBELEM=NBELEM+1                                                           
       IF (NBELEM.GT.NNOE) CALL ERREUR(476)                                     
       IF (IERR.NE.0) RETURN                                                    
      ITRAV1(NBELEM)=I                                                          
 2    CONTINUE                                                                  
      IF(NBELEM.EQ.0) GOTO 3                                                    
      MPOVAL=IPOVAL                                                             
      SEGACT MPOVAL                                                             
      NC=VPOCHA(/2)                                                             
      N=NBELEM                                                                  
      SEGINI MPOVA1                                                             
      SEGINI IPT1                                                               
      IPT1.ITYPEL=1                                                             
      DO 17 I=1,NBELEM                                                          
      IP1=ITRAV1(I)                                                             
      IPT1.NUM(1,I)=NUM(1,IP1)                                                  
      DO 8 IC=1,NC                                                              
      MPOVA1.VPOCHA(I,IC)=VPOCHA(IP1,IC)                                        
 8    CONTINUE                                                                  
 17   CONTINUE                                                                  
      SEGDES MPOVAL                                                             
      SEGDES IPT1,MPOVA1                                                        
      SEGINI MSOUP1                                                             
      MSOUP1.IGEOC=IPT1                                                         
      MSOUP1.IPOVAL=MPOVA1                                                      
      DO 9 IC=1,NC                                                              
      MSOUP1.NOCOMP(IC)=NOCOMP(IC)                                              
      MSOUP1.NOHARM(IC)=NOHARM(IC)                                              
 9    CONTINUE                                                                  
      SEGDES MSOUP1                                                             
      NSOUPO=NSOUPO+1                                                           
      ITRAV2(NSOUPO)=MSOUP1                                                     
 3    CONTINUE                                                                  
      SEGDES MSOUPO,MELEME                                                      
 1    CONTINUE                                                                  
      SEGSUP ICPR    
      NAT=JATTRI(/1)                                                          
      SEGINI MCHPO1
      DO 10 I=1,NAT
        MCHPO1.JATTRI(I)=JATTRI(I) 
 10   CONTINUE                                                           
      DO 11 I=1,NSOUPO                                                          
        MCHPO1.IPCHP(I)=ITRAV2(I)                                                 
 11   CONTINUE                                                                  
      MCHPO1.IFOPOI=IFOPOI                                                      
      MCHPO1.MTYPOI=MTYPOI
      MCHPO1.MOCHDE=MOCHDE
      SEGDES MCHPO1                                                             
      IRET=MCHPO1                                                               
 5000 CONTINUE                                                                  
      SEGDES MCHPOI                                                             
      SEGSUP ITRAV                                                              
      RETURN                                                                    
      END