C CHAMPO    SOURCE    PV        09/03/12    21:16:53     6325           
      SUBROUTINE CHAMPO(IPCHAM,IMOY,IPCHPO,IRET)                                
C=======================================================================        
C                                                                               
C     TRANSFORME UN MCHAML EN CHPOINT                                           
C                                                                               
C                                                                               
C     ATTENTION LES COMPOSANTES DE IPCHAM NE DOIVENT PAS ETRE '    '            
C                               ( DES MOT BLANCS )                              
C                                                                               
C  ENTREES                                                                      
C                                                                               
C     IPCHAM=Pointeur sur un MCHAML                                             
C     IMOY  =1 si moyenne sur les elements, 0 si somme                          
C                                                                               
C  SORTIES                                                                      
C                                                                               
C     IPCHPO=Pointeur sur un CHPOINT                                            
C     IRET=1 OU 0 suivant succes ou non                                         
C                 Message d'erreur imprime si IRET=0                            
C                                                                               
C                                                                               
C=======================================================================        
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)                                                  
-INC SMCHAML                                                                    
-INC SMCHPOI                                                                    
-INC SMELEME                                                                    
-INC SMCOORD                                                                    
-INC CCOPTIO                                                                    
-INC TMTRAV                                                                     
*                                                                               
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))                                          
      SEGMENT MTRA1                                                             
       CHARACTER*4 ICOMP(0)                                                     
      ENDSEGMENT                                                                
      SEGMENT MTRA2                                                             
       INTEGER     MHAR(0)                                                      
      ENDSEGMENT                                                                
C                          POUR LE CHAPEAU DU CHPOINT                           
      JFLAG=0                                                                   
      IF (IMOY.GE.10) THEN                                                      
        JFLAG=1                                                                 
        IMOY=IMOY-10                                                            
      ENDIF                                                                     
*                                                                               
*     ACTIVATION DU MCHAML                                                      
*                                                                               
      IRET=1                                                                    
      MCHELM=IPCHAM                                                             
      SEGACT MCHELM                                                             
*  COMME ON UTILISE INFCHE(??,3) ON S'ASSURE QU'IL EXISTE BIEN                  
      L1=TITCHE(/1)                                                             
      N1=INFCHE(/1)                                                             
      N3=MAX(INFCHE(/2),3)                                                      
      IF (N3.NE.INFCHE(/2)) SEGADJ MCHELM                                       
      IFACHE=IFOCHE                                                             
      NSOUS =ICHAML(/1)                                                         
C-----------------------------------------------------------------------        
C                                                                               
C     BOUCLE SUR LES SOUS REFERENCES DU CHAMELEM                                
C              MISE EN PLACE DES NOMS DE COMPOSANTES DANS ICOMP                 
C                                                                               
C-----------------------------------------------------------------------        
      SEGINI MTRA1,MTRA2                                                        
      SEGINI ICPR                                                               
      NNNOE=0                                                                   
*                                                                               
*     BOUCLE SUR LES SOUS ZONES                                                 
*                                                                               
      DO 100 ISOUS=1,NSOUS                                                      
*                                                                               
*       ACTIVATION DU MELEME                                                    
*                                                                               
        MELEME = IMACHE(ISOUS)                                                  
        MCHAML = ICHAML(ISOUS)                                                  
        SEGACT MCHAML                                                           
*  activation des melval
        DO ID=1,IELVAL(/1)
            MELVAL=IELVAL(ID)                                                   
            SEGACT MELVAL                                                       
        ENDDO
*                                                                               
*       RECOPIE DES NOMS DE COMPOSANTES                                         
*                                                                               
        DO 110 IB=1,NOMCHE(/2)                                                  
          DO 120 IC=1,ICOMP(/2)                                                 
            IF(ICOMP(IC).EQ.NOMCHE(IB)(1:4)                                     
     1         .AND.MHAR(IC).EQ.INFCHE(ISOUS,3)) GOTO 110                       
  120     CONTINUE                                                              
          ICOMP(**)=NOMCHE(IB)(1:4)                                             
          MHAR(**) =INFCHE(ISOUS,3)                                             
  110   CONTINUE                                                                
*                                                                               
*       RECUPERATION DES NUMEROS DE NOEUDS                                      
*                                                                               
        SEGACT MELEME                                                           
        DO 111 IOP = 1,NUM(/1)                                                  
        DO 111 JOP= 1,NUM(/2)                                                   
          IPT= NUM(IOP,JOP)                                                     
          IF(ICPR(IPT).EQ.0) THEN                                               
          NNNOE=NNNOE+1                                                         
          ICPR(IPT)=NNNOE                                                       
          ENDIF                                                                 
  111   CONTINUE                                                                
  100 CONTINUE                                                                  
*                                                                               
      NNIN=ICOMP(/2)                                                            
      SEGINI MTRAV                                                              
      DO 112 IOP=1,NNIN                                                         
        INCO(IOP)=ICOMP(IOP)                                                    
        NHAR(IOP)=MHAR(IOP)                                                     
  112 CONTINUE                                                                  
C                                                                               
C     INITIALISATION DE CC STOCKANT LES VALEURS DU CHPOINT                      
C                                                                               
C                                                                               
C                                                                               
C-----------------------------------------------------------------------        
C                                                                               
C     BOUCLE SUR LES SOUS REFERENCES DU CHAMP PAR ELEMENT                       
C                                                                               
C-----------------------------------------------------------------------        
      DO 300 ISOUS=1,NSOUS                                                      
*                                                                               
        MELEME=IMACHE(ISOUS)                                                    
        MCHAML=ICHAML(ISOUS)                                                    
        NCP=NOMCHE(/2)                                                          
C                                                                               
        NBNN  =NUM(/1)                                                          
        NBELEM=NUM(/2)                                                          
C                                                                               
C       BOUCLE SUR LES COMPOSANTES LES ELEMENTS ET LES NOEUDS                   
C                                                                               
        DO 320 IB=1,NBELEM                                                      
        DO 320 IC=1,NBNN                                                        
C                                                                               
C         REPERAGE D UN POINT                                                   
          IPT=ICPR(NUM(IC,IB))                                                  
          DO 330 ID=1,NCP                                                       
          DO 330 IE=1,NNIN                                                      
*                                                                               
            MELVAL=IELVAL(ID)                                                   
            NBPTEL=VELCHE(/1)                                                   
            NEL   =VELCHE(/2)                                                   
            IBMN=MIN(IB,NEL)                                                    
            IGMN=MIN(IC,NBPTEL)                                                 
*                                                                               
            IF(NOMCHE(ID)(1:4).NE.ICOMP(IE)                                     
     1         .OR.INFCHE(ISOUS,3).NE.MHAR(IE)) GOTO 330                        
            BVALT=0.                                                            
*                                                                               
            IF (JFLAG.EQ.1) THEN                                                
              DO 331 ICEL=1,NBPTEL                                              
C                                                                               
C               ADDITION DANS BB POUR LES MCHAML AUX NOEUDS                     
C                                                                               
                BVALT=BVALT+VELCHE(ICEL,IBMN)                                   
  331         CONTINUE                                                          
              BVALT=BVALT/NBPTEL                                                
              BB(IE,IPT)=BB(IE,IPT)+BVALT                                       
            ELSE                                                                
              BB(IE,IPT)=BB(IE,IPT)+VELCHE(IGMN,IBMN)                           
            ENDIF                                                               
            IBIN(IE,IPT)=IBIN(IE,IPT)+1                                         
  330     CONTINUE                                                              
*                                                                               
          IGEO(IPT)=NUM(IC,IB)                                                  
  320   CONTINUE                                                                
*  desactivation des melval
        DO ID=1,IELVAL(/1)
            MELVAL=IELVAL(ID)                                                   
            SEGDES MELVAL
        ENDDO
        SEGDES MCHAML                                                           
  300 CONTINUE                                                                  
*                                                                               
      DO 341 ISOUS=1,NSOUS                                                      
          MELEME=IMACHE(ISOUS)                                                  
          SEGDES MELEME                                                         
 341   CONTINUE                                                                 
*                                                                               
      IF (IMOY.EQ.1) THEN                                                       
        DO 340 IPT=1,NNNOE                                                      
        DO 340 IE=1,NNIN                                                        
          IF (IBIN(IE,IPT).NE.0) THEN                                           
            BB(IE,IPT)=BB(IE,IPT)/IBIN(IE,IPT)                                  
          ELSE                                                                  
            BB(IE,IPT)=0.                                                       
          ENDIF                                                                 
 340    CONTINUE                                                                
      ENDIF                                                                     
*                                                                               
      CALL CRECHP(MTRAV,IPCHPO)                                                 
      SEGSUP MTRAV,ICPR,MTRA1,MTRA2                                             
      MCHPOI=IPCHPO                                                             
      SEGACT MCHPOI*MOD
      IFOPOI=IFACHE                                                             
      MTYPOI=TITCHE 
      IF ( IMOY .EQ. 0) THEN
*       on somme les participations des elements: discret
         JATTRI(1) =  2
      ELSE
*      on prend la moyenne entre les éléments: diffus
         JATTRI(1) = 1
      ENDIF                                                           
      SEGDES MCHPOI                                                             
      SEGDES MCHELM                                                             
      RETURN                                                                    
      END