C CREDEF    SOURCE    CHAT      05/01/12    22:29:05     5004           
C  CE SOUS-PROGRAMME CREE LES CHAMPS DE COORDONNEES ASSOCIES AUX                
C  DEFORMES. IL ACTUALISE LES ELEMENTS SUR CES CHAMPS                           
C                                                                               
      SUBROUTINE CREDEF(KABEL,KABCOR,KABCPR,MDEFOR,LABCO2,AMPIMP)
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO                                                                    
-INC CCREEL
-INC SMELEME                                                                    
-INC SMCOORD                                                                    
-INC SMCHPOI                                                                    
-INC SMDEFOR                                                                    
-INC SMVECTE                                                                    
      SEGMENT KABEL(NDEF)                                                       
      SEGMENT KABCOR(NDEF)                                                      
      SEGMENT KABCPR(NDEF)                                                      
      SEGMENT LABCO2(3,NDEF)                                                    
      SEGMENT XCO(IDIM,NCO)                                                     
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))                                          
      CHARACTER*4 NODEF(3),NODEG(3)                                             
      DATA NODEF /'UX  ','UY  ','UZ  '/                                         
      DATA NODEG /'UR  ','UZ  ','UT  '/                                         
      LABCO2=0                                                                  
      SEGACT MCOORD                                                             
      SEGACT MDEFOR                                                             
      NDEF=AMPL(/1)                                                             
      SEGINI KABEL,KABCOR,KABCPR,LABCO2                                         
      DO 200 IDEF=1,NDEF                                                        
      LABCO2(3,IDEF)=MTVECT(IDEF)                                               
      SEGINI ICPR                                                               
      KABCPR(IDEF)=ICPR                                                         
      DO 10 I=1,XCOOR(/1)/(IDIM+1)                                              
      ICPR(I)=0                                                                 
  10  CONTINUE                                                                  
      NCO=0                                                                     
      MELEME=IELDEF(IDEF)                                                       
      KABEL(IDEF)=MELEME                                                        
      SEGACT MELEME                                                             
      NBSOUS=LISOUS(/1)                                                         
      IPT1=MELEME                                                               
      DO 20 ISOUS=1,MAX(1,NBSOUS)                                               
      IF (NBSOUS.NE.0) THEN                                                     
       IPT1=LISOUS(ISOUS)                                                       
       SEGACT IPT1                                                              
      ENDIF                                                                     
      DO 22 I=1,IPT1.NUM(/1)                                                    
      DO 22 J=1,IPT1.NUM(/2)                                                    
      IP=IPT1.NUM(I,J)                                                          
      IF (ICPR(IP).NE.0) GOTO 22                                                
      NCO=NCO+1                                                                 
      ICPR(IP)=NCO                                                              
  22  CONTINUE                                                                  
  20  CONTINUE                                                                  
C  MAINTENANT CREER LES COORDONNEES DEFORMES                                    
      SEGINI XCO                                                                
      DO 40 J=1,XCOOR(/1)/(IDIM+1)                                              
      IPC=ICPR(J)                                                               
      IF (IPC.EQ.0) GOTO 40                                                     
      IREF=(IDIM+1)*(J-1)                                                       
      DO 41 I=1,IDIM                                                            
      XCO(I,IPC)=XCOOR(IREF+I)                                                  
  41  CONTINUE                                                                  
  40  CONTINUE                                                                  
      KABCOR(IDEF)=XCO                                                          
      MCHPOI=ICHDEF(IDEF)                                                       
C#      if (ampimp.lt.xgrand/2) then
      if (ampimp.lt.xsgran/2) then
       amp=ampimp
      else
       AMP=AMPL(IDEF)
      endif
      SEGACT MCHPOI                                                             
      NSOUPO=IPCHP(/1)                                                          
      DO 60 ISOUP=1,NSOUPO                                                      
      MSOUPO=IPCHP(ISOUP)                                                       
      SEGACT MSOUPO                                                             
      MPOVAL=IPOVAL                                                             
      SEGACT MPOVAL                                                             
      IPT2=IGEOC                                                                
      SEGACT IPT2                                                               
      NC=NOCOMP(/2)                                                             
      DO 70 IC=1,NC                                                             
      DO 80 INUM=1,IDIM                                                         
      IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN                                       
      IF (NOCOMP(IC).EQ.NODEF(INUM)) GOTO 81                                    
      ELSE                                                                      
      IF (NOCOMP(IC).EQ.NODEG(INUM)) GOTO 81                                    
      ENDIF                                                                     
  80  CONTINUE                                                                  
      GOTO 70                                                                   
  81  CONTINUE                                                                  
      DO 90 IEL=1,IPT2.NUM(/2)                                                  
      IP=ICPR(IPT2.NUM(1,IEL))                                                  
      IF (IP.EQ.0) GOTO 90                                                      
      XCO(INUM,IP)=XCO(INUM,IP)+AMP*VPOCHA(IEL,IC)                              
  90  CONTINUE                                                                  
  70  CONTINUE                                                                  
      SEGDES IPT2,MPOVAL,MSOUPO                                                 
  60  CONTINUE                                                                  
      SEGDES MCHPOI                                                             
      IF (LABCO2(3,IDEF).EQ.0) GOTO 200                                         
C  IL FAUT ICI REGARDER LES VECTEURS QUI SONT DANS LA DEFORME                   
      MVECTE=LABCO2(3,IDEF)                                                     
      CALL CREVEC(MELEME,ICPR,KABCOR,LABCO2,MVECTE,IDEF)                        
 200  CONTINUE                                                                  
      SEGDES MDEFOR                                                             
      RETURN                                                                    
      END