C MAPP      SOURCE    CHAT      07/10/29    21:23:55     5940           
      SUBROUTINE MAPP                                                           
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)                                                  
C                                                                               
C=======================================================================        
C   =                                                                  =        
C   = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LES POINTS D'UNE  =        
C   = SECTION DE POINCARE                                              =        
C   =                                                                  =        
C   = SYNTAXE : CART = MAPP (COUL) EVOLF EVOLD EVOLV                   =        
C   =                                                                  =        
C   = SUR UN EVENEMENT SE PRODUISANT SUR EVOLF A L'ABSCISSE T, ON      =        
C   = EMPLIT CART AVEC L'ORDONNEE A L'ABSCISSE T DE EVOLD, EN ABSCISSE =        
C   = ET L'ORDONNEE A L'ABSCISSE T DE EVOLV, EN ORDONNEE.              =        
C   =                                                                  =        
C   = L'EVENEMENT EST LE PASSAGE DE 0. A UNE VALEUR DE L'ORDONNEE DE   =        
C   = EVOLF                                                            =        
C   =                                                                  =        
C   =                                                                  =        
C   =   MEVOL1  :  POINTEUR SUR MEVOLF (OBJET EVOLUTION)               =        
C   =   MEVOL2  :  POINTEUR SUR MEVOLD     "      "                    =        
C   =   IPOMEV  :  POINTEUR SUR MEVOLV     "      "                    =        
C   =   KEVOL1  :  POINTEUR SUR KEVOLF                                 =        
C   =   KEVOL2  :  POINTEUR SUR KEVOLD                                 =        
C   =   IPOKEV  :  POINTEUR SUR KEVOLV                                 =        
C   =   MLREE1  :  POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLF          =        
C   =   MLREE2  :  POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLD          =        
C   =   IPOVIT  :  POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLV          =        
C   =                                                                  =        
C   = CREATION : 25/03/87                                              =        
C   = PROGRAMMATEUR : BEAUFILS                                         =        
C=======================================================================        
C                                                                               
-INC CCGEOME                                                                    
-INC CCOPTIO                                                                    
-INC SMEVOLL                                                                    
-INC SMLREEL                                                                    
C                                                                               
      CHARACTER*12 MOTX,MOTY                                                    
      CHARACTER *72 TI                                                          
C                                                                               
      CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)                                         
      IF(ICOUL.EQ.0) ICOUL=IDCOUL+1
      ICOUL=ICOUL-1
C                                                                               
      CALL LIROBJ('EVOLUTIO',IPEV1,1,IRET)                                      
      CALL LIROBJ('EVOLUTIO',IPEV2,1,IRET)                                      
      CALL LIROBJ('EVOLUTIO',IPEV3,1,IRET)                                      
C                                                                               
      IF(IERR.NE.0) GOTO 100                                                    
C                                                                               
C     LES 3 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR                      
C                                                                               
      MEVOL1=IPEV1                                                              
      SEGACT MEVOL1                                                             
      KEVOL1=MEVOL1.IEVOLL(1)                                                   
      SEGACT KEVOL1                                                             
      MLREE1=KEVOL1.IPROGY                                                      
      SEGACT MLREE1                                                             
      L1=MLREE1.PROG(/1)                                                        
C                                                                               
      MEVOL2=IPEV2                                                              
      SEGACT MEVOL2                                                             
      KEVOL2=MEVOL2.IEVOLL(1)                                                   
      SEGACT KEVOL2                                                             
      MOTX=KEVOL2.NOMEVY                                                        
      MLREE2=KEVOL2.IPROGY                                                      
      SEGACT MLREE2                                                             
      L2=MLREE2.PROG(/1)                                                        
C                                                                               
      MEVOLL=IPEV3                                                              
      IPOMEV=IPEV3                                                              
      SEGACT MEVOLL                                                             
      KEVOLL=IEVOLL(1)                                                          
      IPOKEV=IEVOLL(1)                                                          
      SEGACT KEVOLL                                                             
      MOTY=NOMEVY                                                               
      MLREE3=IPROGY                                                             
      SEGACT MLREE3                                                             
      L3=MLREE3.PROG(/1)                                                        
C                                                                               
C                                                                               
      IF((L1.EQ.L2).AND.(L1.EQ.L3))GOTO 10                                      
      CALL ERREUR(337)                                                          
      GOTO 100                                                                  
C                                                                               
C     CREATION DE L'OBJET CART DE TYPE EVOLUTIO                                 
C                                                                               
  10  CONTINUE                                                                  
      N=1                                                                       
      SEGINI MEVOLL                                                             
      IPMAP=MEVOLL                                                              
      TI(1:72)=TITREE                                                           
      IEVTEX=TI                                                                 
      ITYEVO='REEL'                                                             
      SEGINI KEVOLL                                                             
      IEVOLL(1)=KEVOLL                                                          
      TYPX='LISTREEL'                                                           
      TYPY='LISTREEL'                                                           
      KEVTEX=TI                                                                 
C                                                                               
      NOMEVX=MOTX                                                               
      NOMEVY=MOTY                                                               
      NUMEVX=ICOUL                                                              
      NUMEVY='REEL'                                                             
C                                                                               
      JG=0                                                                      
      SEGINI MLREEL                                                             
      IPROGX=MLREEL                                                             
      SEGINI MLREEL                                                             
      IPROGY=MLREEL                                                             
C                                                                               
C     L'EVENEMENT EST PRIS SUR LE PREMIER OBJET EVOLUTION CITE EN               
C     ARGUMENT                                                                  
C                                                                               
      ICHO=0                                                                    
        DO 20 I=1,L1                                                            
        FORC=MLREE1.PROG(I)                                                     
        IF(ABS(FORC).GT.1.E-10) THEN                                            
C                                                                               
C     IL Y A CHOC                                                               
C                                                                               
            IF(ICHO.EQ.0) THEN                                                  
C                                                                               
C     ON TIENT L'EVENEMENT                                                      
C                                                                               
                ICHO=1                                                          
C                                                                               
C     LE DEUXIEME OBJET EVOL CONCERNE LE DEPLACEMENT D'UN POINT                 
C     LE TROISIEME OBJET EVOL CONCERNE LA VITESSE DU MEME POINT                 
C                                                                               
                DEPL=MLREE2.PROG(I)                                             
                VITE=MLREE3.PROG(I)                                             
C                                                                               
C     DEPL ET VITE FORMENT UN POINT DE L'OBJET EVOL CREE PAR MAPP               
C                                                                               
                MLREEL=IPROGX                                                   
                JG=PROG(/1)                                                     
                SEGADJ MLREEL                                                   
                PROG(JG)=DEPL                                                   
                MLREEL=IPROGY                                                   
                SEGADJ MLREEL                                                   
                PROG(JG)=VITE                                                   
C                                                                               
            ENDIF                                                               
C                                                                               
C     PAS DE CHOC                                                               
C                                                                               
        ELSE                                                                    
            ICHO=0                                                              
        ENDIF                                                                   
C                                                                               
  20    CONTINUE                                                                
C                                                                               
C     DESACTIVE LES LISTREEL                                                    
C                                                                               
      MLREEL=IPROGX                                                             
      SEGDES MLREEL                                                             
      MLREEL=IPROGY                                                             
      SEGDES MLREEL                                                             
      SEGDES MLREE3,MLREE1,MLREE2                             
C                                                                               
C     DESACTIVE LES MEVOL ET AUTRES KEVOL                                       
C                                                                               
C                                                                               
      SEGDES KEVOLL,MEVOLL                                                      
      SEGDES KEVOL1,MEVOL1                                          
      SEGDES KEVOL2,MEVOL2                                          
      KEVOLL=IPOKEV                                                             
      MEVOLL=IPOMEV                                                             
      SEGDES KEVOLL,MEVOLL                                          
C                                                                               
      CALL ECROBJ('EVOLUTIO',IPMAP)                                             
C                                                                               
 100  CONTINUE                                                                  
      RETURN                                                                    
      END