C PUCHER    SOURCE    BP208322  12/05/24    21:15:03     7378           
      SUBROUTINE PUCHER(IPCHE1,XPU,IPCHPU,IRET)                                 
*_______________________________________________________________________        
*                                                                               
*        ELEVATION A UNE PUISSANCE REEL D'UN CHAMELEM                           
*                                                                               
*  ENTREES :                                                                    
*  ---------                                                                    
*                                                                               
*     IPCHE1  POINTEUR SUR LE CHAMPS PAR ELEMENT A ELEVER A LA PUISSANCE        
*             XPU                                                               
*     XPU     PUISSANCE ( C EST UN REEL POSITIF OU NEGATIF )                    
*                                                                               
*                                                                               
*  SORTIES :                                                                    
*  ---------                                                                    
*                                                                               
*     IPCHPU  POINTEUR SUR LE CHAMELEM RESULTANT                                
*     IPCHPU  =0 SI PB                                                          
*     IRET=1                                                                    
*         =0  SI UNE COMPOSANTE EST NEGATIVE                                    
*                                                                               
*     CODE EBERSOLT AVRIL 85                                                    
*                                                                               
*     PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12/90                    
*                                                                               
*_______________________________________________________________________        
*                                                                               
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)                                                  
*                                                                               
-INC SMCHAML                                                                    
-INC CCOPTIO                                                                    
-INC SMLREEL                                                                    
*                                                                               
      IRET=1                                                                    
      MCHEL1=IPCHE1                                                             
*                                                                               
*     INITIALISATION DU CHAPEAU DU SEGMENT                                      
*                                                                               
      SEGINI,MCHELM=MCHEL1                                                      
      IPCHPU=MCHELM                                                             
      NSOUS=ICHAML(/1)      
      
C     ON ORIENTE SELON LA VALEUR DE XPU (PERFORMANCES)
      if(XPU.eq.0.5d0) goto 100


c----------------------------------------------------------------------
c     Cas général Y**XPU
*                                                                               
*     BOUCLE SUR LES SOUS ZONES                                                 
*                                                                               
      DO 30 ISOUS=1,NSOUS                                                       
         MCHAM1=ICHAML(ISOUS)                                                   
         SEGINI,MCHAML=MCHAM1                                                   
         ICHAML(ISOUS)=MCHAML                                                   
         DO 40 ICOMP=1,IELVAL(/1)                                               
            MELVA1=IELVAL(ICOMP)                                                
            SEGINI,MELVAL=MELVA1                                                
            IELVAL(ICOMP)=MELVAL                                                
            IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN                                 
               N1PTEL=VELCHE(/1)                                                
               N1EL  =VELCHE(/2)                                                
               DO 20 IB=1,N1EL                                               
                  DO 20 IGAU=1,N1PTEL                                              
                     XTRA=VELCHE(IGAU,IB)                                       
                     IF( XTRA.LT.0.) IRET = 0                          
                     IF( XTRA.LE.0.) VELCHE(IGAU,IB)= 0.                                  
                     IF( XTRA.GT.0.) VELCHE(IGAU,IB)= XTRA ** XPU                         
 20            CONTINUE                                                         
            ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN                  
               N2PTEL=IELCHE(/1)                                                
               N2EL  =IELCHE(/2)                                                
               DO 10 IB=1,N2EL                                               
                  DO 10 IGAU=1,N2PTEL                                              
                     MLREE1=IELCHE(IGAU,IB)                                     
                     SEGACT MLREE1                                              
                     JG=MLREE1.PROG(/1)                                         
                     SEGINI MLREEL                                              
                     DO 11 IPROG=1,JG                                           
                        XTRA=MLREE1.PROG(IPROG)                                 
                        IF( XTRA.LT.0.) IRET = 0
                        IF( XTRA.LE.0.) PROG(IPROG)= 0.                               
                        IF( XTRA.GT.0.) PROG(IPROG)= XTRA ** XPU                      
 11                  CONTINUE                                                   
                     IELCHE(IGAU,IB)=MLREEL                                     
                     SEGDES MLREE1,MLREEL                                       
 10            CONTINUE                                                         
            ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
               N2PTEL=IELCHE(/1)
               N2EL  =IELCHE(/2)
               DO 12 IB=1,N2EL
                  DO 12 IGAU=1,N2PTEL
                     MEVOL1=IELCHE(IGAU,IB)
                     IRET=2
                     CALL PUEVOL(MEVOL1,XPU,0,MEVOL2,IRET)
                     IELCHE(IGAU,IB)=MEVOL2
 12            CONTINUE
            ELSE                                                                
*                                                                               
*              NOM DE COMPOSANTE NON RECONNU                                    
*                                                                               
               MOTERR(1:4)='**  '                                               
               MOTERR(5:8)=NOMCHE(ICOMP)                                        
               CALL ERREUR(335)                                                 
               SEGSUP MELVAL,MCHAML,MCHELM                                      
               IPCHPU=0                                                         
               RETURN                                                           
            ENDIF                                                               
            SEGDES MELVAL                                                       
 40      CONTINUE                                                               
         SEGDES MCHAML                                                          
 30   CONTINUE
      GOTO 999
 

c----------------------------------------------------------------------
c     Cas : Y**0.5
 100  CONTINUE                                                         
*                                                                               
*     BOUCLE SUR LES SOUS ZONES                                                 
*                                                                               
      DO 130 ISOUS=1,NSOUS                                                       
         MCHAM1=ICHAML(ISOUS)                                                   
         SEGINI,MCHAML=MCHAM1                                                   
         ICHAML(ISOUS)=MCHAML                                                   
         DO 140 ICOMP=1,IELVAL(/1)                                               
            MELVA1=IELVAL(ICOMP)                                                
            SEGINI,MELVAL=MELVA1                                                
            IELVAL(ICOMP)=MELVAL                                                
            IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN                                 
               N1PTEL=VELCHE(/1)                                                
               N1EL  =VELCHE(/2)                                                
               DO 120 IB=1,N1EL                                               
                  DO 120 IGAU=1,N1PTEL                                              
                     XTRA=VELCHE(IGAU,IB)                                       
                     IF( XTRA.LT.0.) IRET = 0                          
                     IF( XTRA.LE.0.) VELCHE(IGAU,IB)= 0.                                  
                     IF( XTRA.GT.0.) VELCHE(IGAU,IB)= sqrt(XTRA)                        
 120           CONTINUE                                                         
            ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN                  
               N2PTEL=IELCHE(/1)                                                
               N2EL  =IELCHE(/2)                                                
               DO 110 IB=1,N2EL                                               
                  DO 110 IGAU=1,N2PTEL                                              
                     MLREE1=IELCHE(IGAU,IB)                                     
                     SEGACT MLREE1                                              
                     JG=MLREE1.PROG(/1)                                         
                     SEGINI MLREEL                                              
                     DO 111 IPROG=1,JG                                           
                        XTRA=MLREE1.PROG(IPROG)                                 
                        IF( XTRA.LT.0.) IRET = 0
                        IF( XTRA.LE.0.) PROG(IPROG)= 0.                               
                        IF( XTRA.GT.0.) PROG(IPROG)= sqrt(XTRA)                           
 111                 CONTINUE                                                   
                     IELCHE(IGAU,IB)=MLREEL                                     
                     SEGDES MLREE1,MLREEL                                       
 110           CONTINUE                                                         
            ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
               N2PTEL=IELCHE(/1)
               N2EL  =IELCHE(/2)
               DO 112 IB=1,N2EL
                  DO 112 IGAU=1,N2PTEL
                     MEVOL1=IELCHE(IGAU,IB)
                     IRET=2
                     CALL PUEVOL(MEVOL1,XPU,0,MEVOL2,IRET)
                     IELCHE(IGAU,IB)=MEVOL2
 112           CONTINUE
            ELSE                                                                
*                                                                               
*              NOM DE COMPOSANTE NON RECONNU                                    
*                                                                               
               MOTERR(1:4)='**  '                                               
               MOTERR(5:8)=NOMCHE(ICOMP)                                        
               CALL ERREUR(335)                                                 
               SEGSUP MELVAL,MCHAML,MCHELM                                      
               IPCHPU=0                                                         
               RETURN                                                           
            ENDIF                                                               
            SEGDES MELVAL                                                       
 140     CONTINUE                                                               
         SEGDES MCHAML                                                          
 130  CONTINUE
      GOTO 999
 
 

c----------------------------------------------------------------------
c     FIN DU PROGRAMME
 999  CONTINUE
      SEGDES MCHELM                                                             
      RETURN                                                                    
      END