C FENETR    SOURCE    CHAT      05/01/12    23:58:23     5004           
      SUBROUTINE FENETR                                                         
C ======================================================================        
C     FABRICATION D'UN OBJET EVOLUTION CONTENANT LES FONCTIONS                  
C     DE GREEN VUES A TRAVERS UNE FENETRE                                       
C                                                                               
C     GREEN2 = FENE GREEN1 EVOLFE ;                                             
C                                                                               
C     GREEN1: OBJET EVOLUTION CONTENANT LES FONCTIONS DE GREEN                  
C     EVOLFE: OBJET EVOLUTION CONTENANT LA FENETRE                              
C     GREEN2: OBJET EVOLUTION CONTENANT LES FONCTIONS DE GREEN VUES A           
C             TRAVERS LA FENETRE                                                
C                                                                               
C     PROGRAMMEUR : GUILBAUD                                                    
C     CREATION    : 07/10/87                                                    
C ======================================================================        
C                                                                               
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)                                                  
-INC CCOPTIO                                                                    
-INC SMEVOLL                                                                    
-INC SMLREEL                                                                    
      EPS=1.D-3                                                                 
C                                                                               
C   1 - LECTURES                                                                
C                                                                               
      CALL LIROBJ ('EVOLUTIO',IRETG,1,IRETOU)                                   
      IF(IERR.NE.0) RETURN                                                      
      CALL LIROBJ ('EVOLUTIO',IRETF,1,IRETOU)                                   
      IF(IERR.NE.0) RETURN                                                      
C                                                                               
C   2 - VERIFICATIONS                                                           
C                                                                               
      MEVOLL=IRETG                                                              
      SEGACT MEVOLL                                                             
      N=IEVOLL(/1)                                                              
      WRITE(6,*) 'N= ',N                                                        
      KEVOLL=IEVOLL(1)                                                          
      SEGACT KEVOLL                                                             
      MEVOL1=IRETF                                                              
      SEGACT MEVOL1                                                             
      KEVOL1=MEVOL1.IEVOLL(1)                                                   
      SEGACT KEVOL1                                                             
      IPROG1=KEVOL1.IPROGX                                                      
      IF(IPROGX.NE.IPROG1) THEN                                                 
        MLREEL=IPROGX                                                           
        SEGACT MLREEL                                                           
        L=PROG(/1)                                                              
        MLREE1=IPROG1                                                           
        SEGACT MLREE1                                                           
        L1=MLREE1.PROG(/1)                                                      
        IF(L.EQ.L1) CALL VERIPR(PROG(1),MLREE1.PROG(1),L,IRETOU,EPS)            
        SEGDES MLREEL                                                     
        SEGDES MLREE1                                                     
        IF(L.NE.L1.OR.IRETOU.EQ.0) THEN                                         
          SEGDES MEVOLL                                                   
          SEGDES MEVOL1                                                   
          SEGDES KEVOLL                                                   
          SEGDES KEVOL1                                                   
C *** LA FENETRE N'EST PAS APPLICABLE AUX FONCTIONS DE GREEN                    
          CALL ERREUR(393)                                                      
          RETURN                                                                
        ENDIF                                                                   
      ENDIF                                                                     
      MLREE1=KEVOL1.IPROGY                                                      
      SEGDES KEVOL1                                                       
      SEGDES MEVOL1                                                       
      SEGACT MLREE1                                                             
C                                                                               
C   3 - CREATION                                                                
C                                                                               
      SEGINI MEVOL2                                                             
      MEVOL2.ITYEVO=ITYEVO                                                      
      DO 40 NN=1,N                                                              
      KEVOLL=IEVOLL(NN)                                                         
      SEGACT KEVOLL                                                             
      MLREEL=IPROGY                                                             
      SEGACT MLREEL                                                             
      JG=L                                                                      
      SEGINI MLREE2                                                             
      SEGINI KEVOL2                                                             
      KEVOL2.TYPX='LISTREEL'                                                    
      KEVOL2.TYPY='LISTREEL'                                                    
      MEVOL2.IEVOLL(NN)=KEVOL2                                                  
      KEVOL2.NOMEVX=NOMEVX                                                      
      KEVOL2.NOMEVY=NOMEVY                                                      
      KEVOL2.NUMEVX=NUMEVX                                                      
      KEVOL2.NUMEVY=NUMEVY                                                      
      KEVOL2.KEVTEX=KEVTEX                                                      
      DO 30 LL=1,L                                                              
      MLREE2.PROG(LL)=PROG(LL)*MLREE1.PROG(LL)                                  
   30 CONTINUE                                                                  
      KEVOL2.IPROGY=MLREE2                                                      
      KEVOL2.IPROGX=IPROGX                                                      
      SEGDES MLREEL                                                       
      SEGDES KEVOLL                                                       
      SEGDES MLREE2                                                             
      SEGDES KEVOL2                                                             
   40 CONTINUE                                                                  
      SEGDES MLREE1                                                       
      SEGDES MEVOL2                                                             
C                                                                               
C   4 - ECRITURE                                                                
C                                                                               
      IRET2=MEVOL2                                                              
      CALL ECROBJ('EVOLUTIO',IRET2)                                             
      RETURN                                                                    
      END