Télécharger la plaquette Cast3M


fr en

Télécharger calpaq.eso

Retour à la liste

Numérotation des lignes : 

calpaq

  1. C CALPAQ    SOURCE    OF166741  24/10/03    21:15:04     12022          
  2.  
  3.       SUBROUTINE CALPAQ(IPCHE1,IPCHE2,KMUL,TITC,NUMCHA,IRET)
  4.  
  5. *______________________________________________________________________
  6. *
  7. *     GESTION DE LA MULTIPLICATION DES CHAMELEMS
  8. *     __________________________________________
  9. *
  10. *   Cette SUBROUTINE permet de determiner quel type de multiplication
  11. *   ou division va être faite.
  12. *
  13. *
  14. *   ENTREES :
  15. *   ---------
  16. *
  17. *      IPCHE1     POINTEUR SUR UN 1IER MCHAML
  18. *      IPCHE2     POINTEUR SUR UN 2EME MCHAML
  19. *
  20. *      Ces segments sont suposes ACTIFs en ENTREE et en SORTIE
  21. *      Ils ne sont en rien modifies dans le present sous-programme.
  22. *
  23. *   SORTIES :
  24. *   ---------
  25. *      IPCHE1     <-|
  26. *                   |-- POINTEURS EVENTUELLEMENT PERMUTES
  27. *      IPCHE2     <-|
  28. *
  29. *      KMUL       TYPE DE MULTIPLICATION 1 SCALAIRE   PAR SCALAIRE
  30. *                                        2 COMPOSANTE PAR SCALAIRE
  31. *                                        3 COMPOSANTE PAR COMPOSANTE
  32. *                                        4 MATRICE    PAR COMPOSANTE
  33. *                                        5 GRADIENT   PAR GRADIENT
  34. *
  35. *      TITC       contient le TITCHE DU MCHAML A CREER
  36. *                 Par defaut TITC = ' '
  37. *      NUMCHA     LONGUEUR DU TITCHE DU CHAMP (=TITC(1:NUMCHA))
  38. *                 Par defaut NUMCHA = 1
  39. *
  40. *      LPERM      Logique a VRAI(.TRUE.) si les champs ont ete permutes
  41. *                         a FAUX(.FALSE.) sinon
  42. *
  43. *      IRET       = 1 SI OK
  44. *                 = 0 SINON AVEC GESTION ERREUR
  45. *
  46. *   NOTA :  Le logique LPERM peut etre sorti pour utilisation par le 
  47. *   ------  sous-programme appelant.
  48. *      SUBROUTINE CALPAQ(IPCHE1,IPCHE2,KMUL,TITC,NUMCHA,LPERM,IRET)
  49. *_______________________________________________________________________
  50.  
  51.       IMPLICIT INTEGER(I-N)
  52.       IMPLICIT REAL*8(A-H,O-Z)
  53.  
  54. -INC PPARAM
  55. -INC CCOPTIO
  56. -INC SMCHAML
  57.  
  58.       CHARACTER*(*) TITC
  59.       LOGICAL LPERM
  60.  
  61.       PARAMETER (NTIT=22)
  62.       CHARACTER*(72) TIT1,TIT2, TITNOU(NTIT)
  63.  
  64.       DATA TITNOU / 'NOEUD', 'GRAVITE', 'RIGIDITE', 'MASSE',
  65.      &              'STRESSES', 'DEPLACEMENTS',   'FORCES',
  66.      &              'REACTUALISATION',      'FORCES VOLUMIQUES',
  67.      &              'GRADIENT', 'CONTRAINTES', 'DEFORMATIONS',
  68.      &              'CARACTERISTIQUES', 'BIDON',
  69.      &              'TEMPERATURES', 'CONTRAINTES PRINCIPALES',
  70.      &              'MATRICE DE HOOKE', 'MATRICE DE HOOKE TANGENTE',
  71.      &              'DILATATIONS', 'VARIABLES INTERNES',
  72.      &              'GRADIENT DE FLEXION','VON MISES'/
  73.  
  74.       MCHEL1 = IPCHE1
  75.       MCHEL2 = IPCHE2
  76. *      segact,MCHEL1,MCHEL2    <- supposes ACTIFs en E/S
  77.  
  78. * Analyse du champ 1 (IPCHE1)
  79.       TIT1  = MCHEL1.TITCHE
  80.       INU1  = 0
  81.       INUK1 = 0
  82.       IF (TIT1.EQ.'SCALAIRE') THEN
  83.         INU1 = MCHEL1.INFCHE(1,6)
  84.         IF (INU1.EQ.0) INU1=1
  85.         GOTO 1
  86.       ENDIF
  87.       CALL PLACE(TITNOU,NTIT,INU1,TIT1)
  88.       IF (INU1.EQ.0) THEN
  89. * y a-t'il une unique composante scalaire ?
  90.         nc = MCHEL1.ICHAML(/1)
  91.         DO ic = 1, nc
  92.           MCHAM1 = MCHEL1.ICHAML(ic)
  93.           SEGACT,MCHAM1
  94.           IF (MCHAM1.NOMCHE(/2).NE.1) THEN
  95.             INUK1 = 2
  96.           ELSE
  97.             IF (MCHAM1.NOMCHE(1).NE.'SCAL') INUK1 = 2
  98.           ENDIF
  99.         ENDDO
  100.       ENDIF
  101.  1    CONTINUE
  102. *      write(ioimp,*) 'CHE1',ipche1,'TIT1',tit1,INU1,INUK1
  103.  
  104. * Analyse du champ 2 (IPCHE2)
  105.       TIT2  = MCHEL2.TITCHE
  106.       INU2  = 0
  107.       INUK2 = 0
  108.       IF (TIT2.EQ.'SCALAIRE') THEN
  109.         INU2 = MCHEL2.INFCHE(1,6)
  110.         IF (INU2.EQ.0) INU2 = 1
  111.         GOTO 2
  112.       ENDIF
  113.       CALL PLACE(TITNOU,NTIT,INU2,TIT2)
  114.       IF (INU2.EQ.0) THEN
  115.         nc = MCHEL2.ICHAML(/1)
  116. * y a-t'il une unique composante scalaire ?
  117.         DO ic = 1, nc
  118.           MCHAM2 = MCHEL2.ICHAML(ic)
  119.           SEGACT,MCHAM2
  120.           IF (MCHAM2.NOMCHE(/2).NE.1) THEN
  121.             INUK2 = 2
  122.           ELSE
  123.             IF (MCHAM2.NOMCHE(1).NE.'SCAL') INUK2 = 2
  124.           ENDIF
  125.         ENDDO
  126.       ENDIF
  127.  2    CONTINUE
  128. *      write(ioimp,*) 'CHE2',ipche2,'TIT2',tit2,INU2,INUK2
  129.  
  130. * S. PASCAL
  131. * Traitement particulier dans le cas d'un produit de 2 MCHAMLs
  132. * a plusieurs composantes dont certaines sont de type EVOLUTIOn.
  133. * Je cherche dans le MCHEL1 les composantes de type EVOL.
  134. *    Si aucune EVOL, INUJ1=0
  135. *    Si toute EVOL,  INUJ1>0
  136. *    Sinon,          INUJ1<0
  137. * Idem pour MCHEL2 avec INUJ2
  138. * Je me place dans le cas d'un produit composante par composante :
  139.       INUJ1 = 0
  140.       INUJ2 = 0
  141.       IF (INU1.EQ.INU2 .AND. INU1.GT.5) THEN
  142.         nc = MCHEL1.ICHAML(/1)
  143.         NJ1 = 0
  144.         DO ic = 1, nc
  145.           MCHAM1 = MCHEL1.ICHAML(ic)
  146.           SEGACT,MCHAM1
  147.           NJ = MCHAM1.IELVAL(/1)
  148.           DO JELV = 1, NJ
  149.             IF (MCHAM1.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
  150.               INUJ1 = INUJ1 + 1
  151.             ENDIF
  152.           ENDDO
  153.           NJ1 = NJ1 + NJ
  154.         ENDDO
  155. *       IF (INUJ1.GT.0) THEN
  156.           IF (INUJ1.NE.NJ1) INUJ1 = 0 - INUJ1
  157. *       ENDIF
  158.         nc = MCHEL2.ICHAML(/1)
  159.         NJ2 = 0
  160.         DO ic = 1, nc
  161.           MCHAM2 = MCHEL2.ICHAML(ic)
  162.           SEGACT,MCHAM2
  163.           NJ = MCHAM2.IELVAL(/1)
  164.           DO JELV = 1, NJ
  165.             IF (MCHAM2.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
  166.               INUJ2 = INUJ2 + 1
  167.             ENDIF
  168.           ENDDO
  169.           NJ2 = NJ2 + NJ
  170.         ENDDO
  171. *       IF (INUJ2.GT.0) THEN
  172.           IF (INUJ2.NE.NJ2) INUJ2 = 0 - INUJ2
  173. *       ENDIF
  174.       ENDIF
  175. *      write(ioimp,*) ' inuj1,inuj2 ',inuj1,inuj2
  176.  
  177.       TITC   = ' '
  178.       NUMCHA = 1
  179.       LPERM  = .FALSE.
  180.       IRET   = 1
  181.  
  182.       IF (INU1.EQ.0.AND.INUK1.EQ.0) THEN
  183.          IF (INU2.LE.1.AND.INUK2.EQ.0) THEN
  184.            KMUL = 1
  185.          ELSE
  186.            KMUL = 2
  187.            LPERM = .TRUE.
  188.          ENDIF
  189.       ELSEIF(INU2.EQ.0.AND.INUK2.EQ.0) THEN
  190.          KMUL = 2
  191.       ELSEIF(INU1.EQ.0.OR.INU2.EQ.0) THEN
  192.          KMUL = 3
  193.       ELSEIF(INU1.EQ.INU2.AND.INU1.LE.5.AND.INU1.GE.1) THEN
  194.          KMUL = 1
  195.       ELSEIF(INU1.EQ.10.AND.INU2.EQ.10) THEN
  196.          TITC   = 'GRADIENT'
  197.          NUMCHA = 8
  198.          KMUL = 5
  199.       ELSEIF(INU1.EQ.10.AND.INU2.EQ.21) THEN
  200.          TITC   = 'GRADIENT'
  201.          NUMCHA = 8
  202.          KMUL = 5
  203.       ELSEIF(INU1.EQ.21.AND.INU2.EQ.10) THEN
  204.          TITC   = 'GRADIENT DE FLEXION'
  205.          NUMCHA = 19
  206.          KMUL = 5
  207.       ELSEIF(INU1.EQ.21.AND.INU2.EQ.21) THEN
  208.          TITC   = 'GRADIENT DE FLEXION'
  209.          NUMCHA = 19
  210.          KMUL = 5
  211.       ELSEIF(INU1.EQ.INU2.AND.INU1.GT.5) THEN
  212.          KMUL = 3
  213.          IF ( (INUJ1.EQ.0.AND.INUJ2.NE.0) .OR.
  214.      &        (INUJ1.LT.0.AND.INUJ2.GT.0) ) THEN
  215.            LPERM = .TRUE.
  216.          ENDIF
  217.       ELSEIF(INU1.EQ.1.AND. INU2.GT.5) THEN
  218.          KMUL = 2
  219.          LPERM = .TRUE.
  220.       ELSEIF(INU2.EQ.1.AND. INU1.GT.5) THEN
  221.          KMUL = 2
  222.       ELSEIF((INU1.EQ.3 .OR. INU1.EQ.6).AND.
  223.      &       (INU2.EQ.13.OR.INU2.EQ.14.OR.INU2.EQ.17)) THEN
  224.          KMUL = 2
  225.          LPERM = .TRUE.
  226.       ELSEIF((INU2.EQ.3 .OR. INU2.EQ.6).AND.
  227.      &       (INU1.EQ.13.OR.INU1.EQ.14.OR.INU1.EQ.17)) THEN
  228.          KMUL = 2
  229.       ELSEIF(INU1.EQ.5 .AND.
  230.      &       (INU2.EQ.11.OR.INU2.EQ.12.OR.
  231.      &        INU2.EQ.15.OR.INU2.EQ.16.OR.INU2.EQ.18)) THEN
  232.          KMUL = 2
  233.          LPERM = .TRUE.
  234.       ELSEIF(INU2.EQ.5 .AND.
  235.      &       (INU1.EQ.11.OR.INU1.EQ.12.OR.
  236.      &        INU1.EQ.15.OR.INU1.EQ.16.OR.INU1.EQ.18)) THEN
  237.          KMUL = 2
  238.       ELSEIF(INU1.EQ.11 .AND. (INU2.EQ.17.OR.INU2.EQ.18)) THEN
  239.          TITC   = 'DEFORMATIONS'
  240.          NUMCHA = 12
  241.          KMUL = 4
  242.       ELSEIF(INU2.EQ.11 .AND. (INU1.EQ.17.OR.INU1.EQ.18)) THEN
  243.          TITC   = 'DEFORMATIONS'
  244.          NUMCHA = 12
  245.          KMUL = 4
  246.          LPERM = .TRUE.
  247.       ELSEIF(INU1.EQ.12 .AND. (INU2.EQ.17.OR.INU2.EQ.18)) THEN
  248.          TITC   = 'CONTRAINTES'
  249.          NUMCHA = 11
  250.          KMUL = 4
  251.       ELSEIF(INU2.EQ.12 .AND. (INU1.EQ.17.OR.INU1.EQ.18)) THEN
  252.          TITC   = 'CONTRAINTES'
  253.          NUMCHA = 11
  254.          KMUL = 4
  255.          LPERM = .TRUE.
  256.       ELSE
  257.          IRET  = 0
  258.          KMUL  = 0
  259.       ENDIF
  260.  
  261. * Permutation des 2 champs :
  262.       IF (LPERM) THEN
  263.         iii    = IPCHE2
  264.         IPCHE2 = IPCHE1
  265.         IPCHE1 = iii
  266.       ENDIF
  267.  
  268. *     ERREUR SI LES MCHAMLS QUE L ON TENTE DE MULTIPLIER
  269. *              OU DIVISER SONT INCOMPATIBLES
  270.       IF (IRET.NE.1) THEN
  271.         MOTERR( 1:16) = TIT1(1:16)
  272.         MOTERR(17:32) = TIT2(1:16)
  273.         CALL ERREUR(993)
  274.       ENDIF
  275.  
  276. *      return
  277.       END
  278.  
  279.  
  280.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales