C EXCOMP    SOURCE    FANDEUR   10/12/14    21:16:19     6812           
      SUBROUTINE EXCOMP                                                         
C=======================================================================        
C                                                                               
C     OPERATEUR EXTRACTION D UNE COMPOSANTE D UN CHPOINT                        
C                                           D UN MCHAML                         
C                          DE QUELQUES COMPOSANTES  D UN MCHAML                 
C
C     CH2 =  EXCO  |  MOT1  CH1 ('NOID') (MOT2) |
C                  |                            |('NATURE'|'INDETER') 
C                  |                            |         |'DIFFUS' )  
C                  |                            |         |'DISCRET');
C                  | LISM1 CH1 ('NOID') (LISM2) |                        
C                                                   
C=======================================================================        
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCOPTIO                                                                    
-INC SMLMOTS 
-INC SMCHPOI                                                                   
      CHARACTER*4 NOVE(1),NATU(3),MOT,MOT2,MOT3     
      DATA NOVE/'NOID'/  
      DATA NATU/'INDE','DIFF','DISC'/                                           
C
C       LISTE DE MOT OU MOT SIMPLE
C  
      MOT=' '                                                                   
      LISM1=0
      LISM2=0                                                                   
      CALL LIROBJ('LISTMOTS',LISM1,0,IRT1)                                      
      IF(IRT1.EQ.0) THEN                                                      
        MOT2='SCAL'                                                             
        CALL LIRCHA(MOT,1,IRETOU)                                               
        IF(IERR.NE.0) RETURN     
      ELSE 
         CALL LIROBJ('LISTMOTS',LISM2,0,IRL2) 
      ENDIF                                                                     
C                                                                               
      CALL LIRMOT(NOVE,1,NOID,0)                                                
C                                                                               
      CALL LIROBJ('CHPOINT ',IPCH1,0,IRT2)                                      
      IF(IRT2.EQ.0) GOTO 100   
C-----------------------------------------------
C       CAS D'UN CHPO
C
C       on essaie de lire le nouveau nom et la nature (facultatif)   
      CALL LIRCHA(MOT2,0,IRETOU)
      MCHPOI = IPCH1
      SEGACT MCHPOI
      JATT1 = JATTRI(1)+1
      IF (IRETOU .GE. 1) THEN
        IF (MOT2 .EQ. 'NATU' ) THEN
C               jatt va stocker la nature
          CALL LIRMOT(NATU,3,JATT1,1)
          IF(IERR.NE.0) RETURN 
          MOT2='    '  
        ELSE
C            mot2 est le nouveau nom de la composante
C            on essaie de lire la nature
          CALL LIRCHA(MOT3,0,IRETOU)
          IF (IRETOU .GE. 1) THEN 
            IF (MOT3 .EQ. 'NATU' ) THEN
              CALL LIRMOT(NATU,3,JATT1,1)
              IF(IERR.NE.0) RETURN
            ELSE
C              natu n'est pas specifie on continue...
              CALL REFUS
            ENDIF
          ENDIF
        ENDIF
      ENDIF                                               
C                                                                               
      IF (LISM1.EQ.0) THEN 
C
C               MOT SIMPLE   
C                                                   
         CALL EXCOPP(IPCH1,MOT,IPCH2,MOT2,NOID)                                 
         IF(IERR.NE.0) RETURN                                                   
      ELSE                                                                      
C
C               LISTE DE MOTS
C
         MLMOTS=LISM1                                                           
         SEGACT MLMOTS  
         IF (LISM2.NE.0) THEN
            MLMOT2=LISM2
            SEGACT,MLMOT2
            IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
               CALL ERREUR(217)
               SEGDES MLMOTS,MLMOT2
               RETURN
            ENDIF
         ENDIF                                                        
         IPCH2=0                                                                
         DO 51 IM=1,MOTS(/2)                                                    
         MOT =MOTS(IM)(1:4)   
         IF (LISM2.NE.0) THEN 
            MOT2=MLMOT2.MOTS(IM)(1:4)      
         ELSE                                             
            MOT2=MOTS(IM)(1:4)  
         ENDIF                                                   
         CALL EXCOPP(IPCH1,MOT,IPCH3,MOT2,NOID)                                 
         IF(IERR.NE.0) THEN                                                     
           SEGDES MLMOTS 
           IF (LISM2.NE.0) SEGDES MLMOT2 
           IF(IPCH2.NE.0) CALL DTCHPO(IPCH2)                                    
           RETURN                                                               
         ENDIF                                                                  
         IF(IPCH2.EQ.0) THEN                                                    
           IPCH2=IPCH3                                                          
         ELSE                                                                   
           CALL ADCHPO(IPCH2,IPCH3,IPCH2,1D0,1D0)
           IF(IERR.NE.0) THEN                                                   
              IF(IPCH2.NE.0) CALL DTCHPO(IPCH2)                                 
              CALL DTCHPO(IPCH3)                                                
              SEGDES MLMOTS 
         IF (LISM2.NE.0) SEGDES MLMOT2
              RETURN                                                            
           ENDIF                                                                
         ENDIF                                                                  
  51     CONTINUE                                                               
         SEGDES MLMOTS 
         IF (LISM2.NE.0) SEGDES MLMOT2 
      ENDIF 
C
C       On ajuste la nature du champ                       
      MCHPOI=IPCH2
      SEGACT MCHPOI*MOD
      mochde=' chpoint cree par EXCOMP'
      mtypoi='SCALAIRE'
      JATTRI(1)=JATT1-1 
      SEGDES MCHPOI
C                                           
      CALL ECROBJ('CHPOINT ',IPCH2)                                             
      RETURN                                                                    
C --------------------------------------------- 
C       CAS D'UN MCHAML
C                                                                             
  100 CONTINUE                                                                  
C                                                                               
      CALL LIROBJ('MCHAML',ICHE1,0,IRT3)                                        
      IF(IRT3.EQ.0) GO TO  300                                                  
      CALL LIRCHA(MOT2,0,IRETOU)                                                
      IF(IRETOU.EQ.0) MOT2=MOT                                                  
C                                                                               
      IF (LISM1.EQ.0) THEN                                                      
      CALL EXCOC1(ICHE1,MOT,ICHE2,MOT2,NOID)                                    
      IF(IERR.NE.0) RETURN                                                      
      ELSE                                                                      
         MLMOTS=LISM1                                                           
         SEGACT MLMOTS 
         IF (LISM2.NE.0) THEN
            MLMOT2=LISM2
            SEGACT,MLMOT2
            IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
               CALL ERREUR(217)
               SEGDES MLMOTS,MLMOT2
               RETURN
            ENDIF
         ENDIF                                                         
         ICHE2=0                                                                
         DO 201 IM=1,MOTS(/2)                                                   
         MOT =MOTS(IM)(1:4)   
         IF (LISM2.NE.0) THEN  
            MOT2=MLMOT2.MOTS(IM)(1:4)  
         ELSE                                                
            MOT2=MOTS(IM)(1:4)    
         ENDIF   
*         write(6,*) 'MOT  MOT2 ' ,  MOT , MOT2 ,NOID                           
         CALL EXCOC1(ICHE1,MOT,ICHE3,MOT2,NOID)                                 
         IF(IERR.NE.0) THEN                                                     
           SEGDES MLMOTS 
           IF (LISM2.NE.0) SEGDES MLMOT2  
           IF(ICHE2.NE.0) CALL DTCHAM(ICHE2)                                    
           RETURN                                                               
         ENDIF                                                                  
         IF(ICHE2.EQ.0) THEN                                                    
           ICHE2=ICHE3                                                          
         ELSE                                                                   
           CALL FUSCHL(ICHE2,ICHE3,ICHE4)
           IF(IERR.NE.0) THEN  
*           call zpchel (iche2,1)
*           call zpchel(iche3,1)                                                
              CALL DTCHAM(ICHE2)                                                
              CALL DTCHAM(ICHE3)                                                
              SEGDES MLMOTS  
              IF (LISM2.NE.0) SEGDES MLMOT2  
              RETURN                                                            
           ENDIF
           ICHE2=ICHE4                                                          
         ENDIF                                                                  
 201     CONTINUE                                                               
         SEGDES MLMOTS   
         IF (LISM2.NE.0) SEGDES MLMOT2 
      ENDIF                                                                     
      CALL ECROBJ('MCHAML',ICHE2)                                               
      RETURN                                                                    
C                                                                               
C    PAS D OPERANDE CORRECTE TROUVE                                             
C                                                                               
 300  CALL QUETYP(MOTERR(1:8),0,IRETOU)                                         
      IF(IRETOU.NE.0) THEN                                                      
         CALL ERREUR (39)                                                       
      ELSE                                                                      
         CALL ERREUR(533)                                                       
      ENDIF                                                                     
      RETURN                                                                    
      END