C CALPAQ    SOURCE    PV        09/03/12    21:16:13     6325           
      SUBROUTINE CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET)     
*______________________________________________________________________         
* 
*     GESTION DE LA MULTIPLICATION DES CHAMELEMS      
*     __________________________________________      
* 
*   ENTREES :                
*   ---------                
* 
*      IPCHE1     POINTEUR SUR UN 1IER MCHAML         
*      IPCHE2     POINTEUR SUR UN 2IEM MCHAML         
* 
* 
*   SORTIES :                
*   ---------                
* 
*      TITC       TITCHE DU MCHAML A CREER            
*                 = ' ' LE MCHAML A CREE EST DONNE PAR NUMCHA 
*      K          TYPE DE MULTIPLICATION 1 SCALAIRE PAR SCALAIRE                
*                                        2 COMPOSANTE PAR SCALAIRE              
*                                        3 COMPOSANTE PAR COMPOSANTE            
*                                        4 MATRICE PAR COMPOSANTE               
*                                        5 GRADIEN PAR GRADIEN
*      IPCHE1     <-|        
*                   |-- POINTEUR EVENTUELLEMENT INVERS{
*      IPCHE2     <-|        
*      NUMCHA     = 0 LE MCHAML A CREE EST DU TYPE DE IPCHE1 APRES              
*                   INVERSION EVENTUELLE DE IPCHE1 ET IPCHE2  
*                 = X LE MCHAML A CREE EST DU TYPE TITC ,LE TITCHE (TITC        
*                     EST DE LONGEUR X                
*      IRET       = 1 SI OK  
*                 = 0 SINON AVEC GESTION ERREUR       
* 
*       EBERSOLT JANVIER 87  
* 
*       PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 30 10 90                
* 
*_______________________________________________________________________        
* 
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO                 
-INC SMCHAML                 
* 
      CHARACTER*72 TIT1,TIT2,TITC   
      PARAMETER (NTIT=22)    
      CHARACTER*72 TITNOU(NTIT)     
* 
* 
      DATA TITNOU / 'NOEUD', 'GRAVITE', 'RIGIDITE', 'MASSE',  
     1              'STRESSES', 'DEPLACEMENTS',   'FORCES',   
     1              'REACTUALISATION',      'FORCES VOLUMIQUES',                
     1              'GRADIENT', 'CONTRAINTES', 'DEFORMATIONS',
     1              'CARACTERISTIQUES', 'BIDON',
     1              'TEMPERATURES', 'CONTRAINTES PRINCIPALES',
     1              'MATRICE DE HOOKE', 'MATRICE DE HOOKE TANGENTE',            
     1              'DILATATIONS', 'VARIABLES INTERNES',      
     1              'GRADIENT DE FLEXION','VON MISES'/
* 
      MCHEL1=IPCHE1          
      MCHEL2=IPCHE2          
      SEGACT MCHEL1,MCHEL2   
      TIT1=MCHEL1.TITCHE     
      TIT2=MCHEL2.TITCHE     
* 
      inuk1=0
      inuk2=0
      k=0
*      write(6,*) 'TIT1' , tit1
      IF (TIT1.EQ.'SCALAIRE') THEN  
         INU1=1              
         IF (MCHEL1.INFCHE(/2).GE.6) THEN             
            INU1=MCHEL1.INFCHE(1,6) 
            IF  (INU1.EQ.0) INU1=1  
         ENDIF               
         GOTO 1              
      ENDIF
*
      CALL PLACE(TITNOU,NTIT,INU1,TIT1)
*      write(6,*) ' inu1 ', inu1    
*
       if (inu1.eq.0) then
         inuk1 = 0 
* y a t il une unique composante scalaire?
          do lkcha = 1,mchel1.ichaml(/1)
            mcham1 = mchel1.ichaml(lkcha)
            segact mcham1
       if (mcham1.nomche(/2).ne.1.or.mcham1.nomche(1).ne.'SCAL') then
        inuk1 = 2
       endif 
           segdes mcham1
          enddo
       endif            
*
 1    CONTINUE               
      IF (TIT2.EQ.'SCALAIRE') THEN  
         INU2=1              
         IF (MCHEL2.INFCHE(/2).GE.6) THEN             
            INU2=MCHEL2.INFCHE(1,6) 
            IF (INU2.EQ.0) INU2=1   
         ENDIF               
        GOTO 2               
      ENDIF
* 
      CALL PLACE(TITNOU,NTIT,INU2,TIT2)               
*
      if (inu2.eq.0) then
        inuk2 = 0 
* y a t il une unique composante scalaire?
         do lkcha = 1,mchel2.ichaml(/1)
           mcham2 = mchel2.ichaml(lkcha)
           segact mcham2
      if (mcham2.nomche(/2).ne.1.or.mcham2.nomche(1).ne.'SCAL') then
       inuk2 = 2
      endif 
          segdes mcham2
         enddo
      endif  
*      write(6,*) ' inu1 , inul1,inu2,inuk2', inu1 , inul1,inu2,inuk2          
* 
* S. PASCAL
* Traitement particulier dans le cas d'un produit de 2 MCHAMLs
* a plusieurs composantes dont certaines sont de type EVOLUTIOn.
* Je cherche dans le MCHEL1 les composantes de type EVOL.
*    Si aucune EVOL, INUJ1=0
*    Si toute EVOL,  INUJ1>0
*    Sinon,          INUJ1<0
* Idem pour MCHEL2 avec INUJ2
* Je me place dans le cas d'un produit composante par composante :
      IF (INU1.EQ.INU2.AND.INU1.GT.5) THEN
        NI=MCHEL1.ICHAML(/1)
        INUJ1=0
        NJ1=0
        DO ICHA=1,NI
          MCHAM1=MCHEL1.ICHAML(ICHA)
          SEGACT MCHAM1
          NJ=MCHAM1.IELVAL(/1)
          DO JELV=1,NJ
            IF (MCHAM1.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
              INUJ1=ABS(INUJ1)+1
            ENDIF
            INUJ1=INUJ1*(2*(INUJ1/(JELV+NJ1))-1)
          ENDDO
          NJ1=NJ1+NJ
        ENDDO
        NI=MCHEL2.ICHAML(/1)
        INUJ2=0
        NJ2=0
        DO ICHA=1,NI
          MCHAM2=MCHEL2.ICHAML(ICHA)
          SEGACT MCHAM2
          NJ=MCHAM2.IELVAL(/1)
          DO JELV=1,NJ
            IF (MCHAM2.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
              INUJ2=ABS(INUJ2)+1
            ENDIF
            INUJ2=INUJ2*(2*(INUJ2/(JELV+NJ2))-1)
          ENDDO
          NJ2=NJ2+NJ
        ENDDO
      ENDIF
*
 2    CONTINUE               
      SEGDES MCHEL1,MCHEL2   
* 
      IRET=1                 
      K=0  
* 
      IF(INU1.EQ.0.AND.inuk1.EQ.0) THEN
         NUMCHA=1            
         TITC=' '            
         K=2       
         inuk1 = IPCHE2
         IPCHE2 = IPCHE1
         IPCHE1 = inuk1      
      ELSE IF(INU2.EQ.0.AND.inuk2.EQ.0) THEN
         NUMCHA=1            
         TITC=' '            
         K=2    
      ELSE IF(INU1.EQ.0.OR.INU2.EQ.0) THEN
         NUMCHA=1            
         TITC=' '            
         K=3    
      ELSE IF(INU1.EQ.INU2.AND.INU1.LE.5.AND.INU1.GE.1) THEN
         NUMCHA=1            
         TITC=' '            
         K=1                 
      ELSE IF(INU1.EQ.10.AND.INU2.EQ.10) THEN         
         NUMCHA=8            
         TITC='GRADIENT'     
         K=5                 
      ELSE IF(INU1.EQ.10.AND.INU2.EQ.21) THEN         
         NUMCHA=8            
         TITC='GRADIENT'     
         K=5                 
      ELSE IF(INU1.EQ.21.AND.INU2.EQ.10) THEN         
         NUMCHA=19           
         TITC='GRADIENT DE FLEXION' 
         K=5                 
      ELSE IF(INU1.EQ.21.AND.INU2.EQ.21) THEN         
         NUMCHA=19           
         TITC='GRADIENT DE FLEXION' 
         K=5                 
      ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5) THEN
         NUMCHA=1
         TITC=' '
         K=3
      ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5.AND.
     &        ((INUJ1.GT.0).OR.(INUJ2.EQ.0))) THEN
         NUMCHA=1
         TITC=' '
         K=3
      ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5.AND.
     &        INUJ1.EQ.0.AND.INUJ2.NE.0) THEN
         NUMCHA=1
         TITC=' '
         III= IPCHE1
         IPCHE1=IPCHE2
         IPCHE2=III
         K=3
      ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5.AND.
     &        INUJ1.LT.0.AND.INUJ2.GT.0) THEN
         NUMCHA=1
         TITC=' '
         III= IPCHE1
         IPCHE1=IPCHE2
         IPCHE2=III
         K=3
      ELSE IF(INU1.EQ.INU2.AND.INU1.GT.5.AND.
     &        INUJ1.LT.0.AND.INUJ2.LT.0) THEN
         NUMCHA=1
         TITC=' '
         K=3
      ELSE IF (INU1.EQ.1.AND.(INU2.EQ.6.OR.INU2.EQ.7)) THEN
         NUMCHA=1
         TITC=' '
         III= IPCHE1
         IPCHE1=IPCHE2
         IPCHE2=III
         K=2
      ELSE IF (INU2.EQ.1.AND.(INU1.EQ.6.OR.INU1.EQ.7)) THEN   
         NUMCHA=1            
         TITC=' '            
         K=2                 
      ELSE IF (INU1.EQ.3.AND.
     &        (INU2.EQ.13.OR.INU2.EQ.14.OR.INU2.EQ.17)) THEN  
         NUMCHA=1            
         TITC=' '            
         III= IPCHE1         
         IPCHE1=IPCHE2       
         IPCHE2=III          
         K=2                 
      ELSE IF (INU2.EQ.3.AND.
     &        (INU1.EQ.13.OR.INU1.EQ.14.OR.INU1.EQ.17)) THEN  
         NUMCHA=1            
         TITC=' '            
         K=2                 
      ELSE IF (INU1.EQ.5.AND.(INU2.EQ.11.OR.INU2.EQ.12.OR.    
     &         INU2.EQ.15.OR.INU2.EQ.16.OR.INU2.EQ.18)) THEN  
         NUMCHA=1            
         TITC=' '            
         III= IPCHE1         
         IPCHE1=IPCHE2       
         IPCHE2=III          
         K=2                 
      ELSE IF (INU2.EQ.5.AND.(INU1.EQ.11.OR.INU1.EQ.12.OR.    
     &         INU1.EQ.15.OR.INU1.EQ.16.OR.INU1.EQ.18)) THEN  
         NUMCHA=1            
         TITC=' '            
         K=2                 
      ELSE IF (INU1.EQ.11.AND.(INU2.EQ.17.OR.INU2.EQ.18)) THEN
         NUMCHA=12           
         TITC='DEFORMATIONS' 
         K=4                 
      ELSE IF (INU1.EQ.12.AND.(INU2.EQ.17.OR.INU2.EQ.18)) THEN
         NUMCHA=11           
         TITC='CONTRAINTES'  
         K=4                 
      ELSE IF (INU2.EQ.11.AND.(INU1.EQ.17.OR.INU1.EQ.18)) THEN
         NUMCHA=12           
         TITC='DEFORMATIONS' 
         III= IPCHE1         
         IPCHE1=IPCHE2       
         IPCHE2=III          
         K=4                 
      ELSE IF (INU2.EQ.12.AND.(INU1.EQ.17.OR.INU1.EQ.18)) THEN
         NUMCHA=11           
         TITC='CONTRAINTES'  
         III= IPCHE1         
         IPCHE1=IPCHE2       
         IPCHE2=III          
         K=4                 
      ELSE 
         IRET=0              
      ENDIF
      IF(IRET.EQ.0) GOTO 166 
* 
      GOTO 666               
* 
  166 CONTINUE               
      IRET=0                 
* 
*     ERREUR LES CHAMELEM QUE L ON TENTE DE MULTIPLIER
*              OU DIVISER SONT INCOMPATIBLES          
* 
      MOTERR(1:16)=TIT1(1:16)  
      MOTERR(17:32)=TIT2(1:16) 
      CALL ERREUR(993)       
* 
  666 CONTINUE               
* 
      RETURN                 
      END