Esope source files

   1 : C TRACHP    SOURCE    CHAT      05/01/13    03:44:18     5004           
   2 :       SUBROUTINE TRACHP(MCHPOI,MTRAV)                                           
   3 : *                                                                               
   4 : *   MET UN CHAMP POINT SOUS FORME DE TRAVAIL                                    
   5 : *                                                                               
   6 :       IMPLICIT INTEGER(I-N)
   7 : -INC SMCOORD                                                                    
   8 : -INC CCOPTIO                                                                    
   9 : -INC SMCHPOI                                                                    
  10 : -INC SMELEME                                                                    
  11 : -INC TMTRAV                                                                     
  12 :       SEGMENT ITRAV                                                             
  13 :           CHARACTER*4 INC(NN)                                                   
  14 :           INTEGER  IHAR(NN)                                                     
  15 :       ENDSEGMENT                                                                
  16 :       NN = 0                                                                    
  17 :       SEGACT MCHPOI                                                             
  18 : *                                                                               
  19 : *  ON ACTIVE TOUS LES SEGMENTS  MSOUPO                                          
  20 : *                                                                               
  21 :       DO 1 I=1,IPCHP(/1)                                                        
  22 :       MSOUPO=IPCHP(I)                                                           
  23 :       SEGACT MSOUPO                                                             
  24 :       NN = NN + NOCOMP(/2)                                                      
  25 :    1  CONTINUE                                                                  
  26 : *                                                                               
  27 : *    CREATION DE ITRAV ET REMPLISSAGE                                           
  28 : *                                                                               
  29 :       NNNOE=0                                                                   
  30 :       SEGINI ITRAV                                                              
  31 :       NNIN=0                                                                    
  32 :       DO 2 I=1,IPCHP(/1)                                                        
  33 :       MSOUPO=IPCHP(I)                                                           
  34 :       DO 3 J=1,NOCOMP(/2)                                                       
  35 :       DO 4 K=1,NNIN                                                             
  36 :       IF(INC(K).NE.NOCOMP(J)) GO TO 4                                           
  37 :       IF(IHAR(K).EQ.NOHARM(J)) GO TO 3                                          
  38 :     4 CONTINUE                                                                  
  39 :       NNIN=NNIN+1                                                               
  40 :       INC(NNIN)=NOCOMP(J)                                                       
  41 :       IHAR(NNIN)=NOHARM(J)                                                      
  42 :    3  CONTINUE                                                                  
  43 :       MELEME=IGEOC                                                              
  44 :       SEGACT MELEME                                                             
  45 :       NNNOE=NNNOE+NUM(/2)                                                       
  46 :    2  CONTINUE                                                                  
  47 : *                                                                               
  48 : *   CREATION DE MTRAV ET REMPLISSAGE                                            
  49 : *                                                                               
  50 :       NDEJ=0                                                                    
  51 :       SEGINI MTRAV                                                              
  52 :       DO 7 I=1,IPCHP(/1)                                                        
  53 :       MSOUPO=IPCHP(I)                                                           
  54 :       MPOVAL=IPOVAL                                                             
  55 :       SEGACT MPOVAL                                                             
  56 :       DO 8 J=1,NOCOMP(/2)                                                       
  57 :       DO 9 K=1,NNIN                                                             
  58 :       IF(NOCOMP(J).NE.INC(K)) GO TO 9                                           
  59 :       IF(NOHARM(J).EQ.IHAR(K)) GO TO 10                                         
  60 :    9  CONTINUE                                                                  
  60 :       CALL ERREUR (5)                                                           
  61 :   10  CONTINUE                                                                  
  62 :       KK=K                                                                      
  63 :       MELEME=IGEOC                                                              
  64 :       DO 11 K=1,NUM(/2)                                                         
  65 :       BB(KK,K+NDEJ)=VPOCHA(K,J)                                                 
  66 :       IBIN(KK,K+NDEJ)=1                                                         
  67 :       IGEO(K+NDEJ)=NUM(1,K)                                                     
  68 :   11  CONTINUE                                                                  
  69 :    8  CONTINUE                                                                  
  70 :       NDEJ=NDEJ+NUM(/2)                                                         
  71 :       SEGDES MELEME                                                       
  72 :       SEGDES MPOVAL                                                       
  73 :       SEGDES MSOUPO                                                       
  74 :    7  CONTINUE                                                                  
  75 :       SEGDES MCHPOI                                                             
  76 :       DO 13 I=1,NNIN                                                            
  77 :       INCO(I)=INC(I)                                                            
  78 :       NHAR(I)=IHAR(I)                                                           
  79 :   13  CONTINUE                                                                  
  80 : *     WRITE(6,30) (INCO(I),I=1,NNIN)                                            
  81 : *     WRITE(6,31) (NHAR(I),I=1,NNIN)                                            
  82 : *     WRITE(6,32) (( IBIN(I,J),I=1,NNIN),J=1,NNNOE)                             
  83 : *     WRITE(6,33) (( BB(I,J),I=1,NNIN),J=1,NNNOE)                               
  84 : *     WRITE(6,36) ( IGEO(I),I=1,NNNOE)                                          
  85 : * 36  FORMAT('  IGEO ', /,(20I4))                                               
  86 : * 30  FORMAT('  INCO ', 6A6)                                                    
  87 : * 31  FORMAT('  NHAR ', 6I6)                                                    
  88 : * 32  FORMAT('  IBIN  ',/,(20I4))                                               
  89 : * 33  FORMAT('  BB    ',/,(1X,6E12.5))                                          
  90 :       SEGDES MTRAV                                                              
  91 :       SEGSUP ITRAV                                                              
  92 :       RETURN                                                                    
  93 :       END                                                                       
  94 :