C COLI      SOURCE    FANDEUR   10/12/14    21:15:33     6812           
      SUBROUTINE COLI                                                           
*_______________________________________________________________________        
*                                                                               
*         COMBINAISON LINEAIRE DE CHPOINT OU DE MCHAML                          
*                                                                               
*                                                                               
* OPERATEUR COLI : OBJ = | FLOT1*OBJ1 + FLOT2*OBJ2 + ...... |                   
*                        | TABLE LISTREEL                   |                   
*                  OPERATION POSSIBLE SUR DES CHPOINTS ET DES CHAMELEMS         
*                                                                               
* PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 01/91                         
* OPERANDES TABLE ET LISTREEL INCORPORES LE 02/98 PAR MO
* LA VERSION DU 02/98 LAISSAIT TROP DE LIBERTE SUR LES INDICES DE 
* LA TABLE.ON NE PERMET DORENAVANT QUE DES INDICES DE TYPE ENTIER ALLANT
* DE 1 a N PAR PAS DE 1  03/98 PAR MO
*_______________________________________________________________________        
*  
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
-INC CCOPTIO                                                                    
-INC SMTABLE 
-INC SMLREEL 
      SEGMENT ITA1(0)                                                           
      SEGMENT ITAN(0)                                                           
*                                                                               
      SEGMENT ITA2                                                              
         REAL*8 TA2(0)                                                          
      ENDSEGMENT                                                                
*                                                                               
      CHARACTER*(8) ITYPE,ITCHPO,ITCHAM,ITTABL,ITYPIND                          
      REAL*8 RET                                                                
      DATA ITCHPO/'CHPOINT '/                                                   
      DATA ITCHAM/'MCHAML  '/                                                   
      DATA ITTABL/'TABLE   '/                                                   
      ICHP=0                                                                    
*                                                                               
C  CHPOINT:
      CALL LIROBJ(ITCHPO,IRET,0,IRETOU)                                         
      IF(IRETOU.EQ.0) GOTO 2                                                    
      ITYPE=ITCHPO                                                              
      GOTO10                                                                    
*                                                                               
C  MCHAML:
 2    CALL LIROBJ(ITCHAM,IRET,0,IRETOU)                                         
      IF(IRETOU.EQ.0) GOTO 4                                                    
      ITYPE=ITCHAM                                                              
      GOTO10                                                                    
************************************************                                                                               
C  TABLE et LISTREEL :
 4    CALL LIROBJ(ITTABL,IRET,0,IRETOU)                                         
      IF(IRETOU.EQ.0) GOTO 1                                                    
      MTABLE=IRET                                                               
      SEGACT MTABLE                                                             
      NB=MLOTAB                                                                 
* la table ne doit contenir que des champs ET doit etre
*                           indicee par des entiers de 1 a n
      IF((MTABTV(1).NE.'CHPOINT ').AND.(MTABTV(1).NE.'MCHAML  ')) THEN
             MOTERR(1:8)=MTABTV(1)
             SEGDES MTABLE
             CALL ERREUR (39)       
             RETURN
      ENDIF 
      IF ((MTABTI(1).NE.'ENTIER  ').OR.(MTABII(1).NE.1))THEN
             MOTERR(1:8)='ENTIER  '
             INTERR(1)=IRET
             INTERR(2)=1
             SEGDES MTABLE
             CALL ERREUR (58)
             RETURN
      ENDIF 
      ITYPE=MTABTV(1)
      ITYPIND=MTABTI(1)  
      IIND=MTABII(1)-1

      CALL LIROBJ('LISTREEL',IRETR,0,IRETOU)                                    
      IF(IRETOU.EQ.0) GOTO 1                                                    
*
      ICHP=1
      MLREEL= IRETR
      SEGACT MLREEL
* test dime de tab = dime listreel 
      IF(NB.NE.PROG(/1)) THEN
         SEGDES MLREEL
         SEGDES MTABLE
         CALL ERREUR (217)
         RETURN
      ENDIF
      SEGINI ITA1
      SEGINI ITA2
*on teste: si les indices se suivent de 1 a n par pas de 1
*        : si les champs sont tous du meme type
* et on remplit les vecteurs ITA1 et TA2 

      DO 5 IJ=1,NB                                                             
          IF( IJ.NE.MTABII(IJ))THEN  
C           print *,'les indices ne se suivent pas'
                SEGDES MTABLE 
                SEGSUP ITA1
                SEGSUP ITA2
                SEGDES MLREEL 
                CALL ERREUR (211)
                RETURN
          ENDIF 
          IF (MTABTV(IJ).NE.ITYPE) THEN
                MOTERR(1:8)=ITYPE
                SEGDES MTABLE 
                SEGSUP ITA1
                SEGSUP ITA2
                SEGDES MLREEL 
                CALL ERREUR (225)
                RETURN
          ENDIF 
C extraction des champs
         ITA1(**)=MTABIV(IJ)                                                    
C extraction des reels
         TA2(**)=(PROG (IJ))         
 5    CONTINUE
      SEGDES MTABLE                                                             
      SEGDES MLREEL 
C
      GOTO 100                                                                  
C                                                                               
C    PAS D OPERANDE CORRECT TROUVE                                             
C                                                                               
 1    CALL QUETYP(MOTERR(1:8),0,IRETOU)                                         
      IF(IRETOU.NE.0) THEN                                                      
         CALL ERREUR (39)                                                       
      ELSE                                                                      
         CALL ERREUR(533)                                                       
      ENDIF                                                                     
      RETURN                                                                    
*                                                                               
 10   ICHP=1                                                                    
      SEGINI ITA1                                                               
      SEGINI ITA2                                                               
      ITA1(**)=IRET                                                             
      CALL LIRREE(RET,1,IRETOU)                                                 
      IF(IERR.NE.0) GOTO 5001                                                   
      TA2(**)=RET                                                               
 11   CALL LIROBJ(ITYPE,IRET,0,IRETOU)                                          
      IF(IRETOU.EQ.0) GO TO 100                                                 
      ITA1(**)=IRET                                                             
      CALL LIRREE(RET,1,IRETOU)                                                 
      IF(IERR.NE.0) GOTO 5001                                                   
      TA2(**)=RET                                                               
      GOTO 11                                                                   
*                                                                               
 100  CONTINUE                                                                  
      SEGDES ITA1,ITA2                                                          
      IF(ITYPE.EQ.ITCHPO)      CALL COMBIL(ITA1,ITA2,IRET)                      
      IF(ITYPE.EQ.ITCHAM)      CALL COMBYL(ITA1,ITA2,IRET)                      
      IF(IERR.NE.0) GOTO 5001                                                   
*                                                                               
      IF(ICHP.EQ.1) THEN                                                        
         CALL ECROBJ(ITYPE,IRET)                                                
      ENDIF                                                                     
*                                                                               
 5001 CONTINUE                                                                  
      SEGSUP ITA1                                                               
      SEGSUP ITA2                                                               
*                                                                               
      RETURN                                                                    
      END