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/03/14    21:15:01     11868          
  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 = 1
  84.         IF (MCHEL1.INFCHE(/2).GE.6) THEN
  85.           INU1 = MCHEL1.INFCHE(1,6)
  86.           IF (INU1.EQ.0) INU1=1
  87.         ENDIF
  88.         GOTO 1
  89.       ENDIF
  90.       CALL PLACE(TITNOU,NTIT,INU1,TIT1)
  91.       IF (INU1.EQ.0) THEN
  92. * y a-t'il une unique composante scalaire ?
  93.         nc = MCHEL1.ICHAML(/1)
  94.         DO ic = 1, nc
  95.           MCHAM1 = MCHEL1.ICHAML(ic)
  96.           SEGACT,MCHAM1
  97.           IF (MCHAM1.NOMCHE(/2).NE.1) THEN
  98.             INUK1 = 2
  99.           ELSE
  100.             IF (MCHAM1.NOMCHE(1).NE.'SCAL') INUK1 = 2
  101.           ENDIF
  102.         ENDDO
  103.       ENDIF
  104.  1    CONTINUE
  105. *      write(ioimp,*) 'CHE1',ipche1,'TIT1',tit1,INU1,INUK1
  106.  
  107. * Analyse du champ 2 (IPCHE2)
  108.       TIT2  = MCHEL2.TITCHE
  109.       INU2  = 0
  110.       INUK2 = 0
  111.       IF (TIT2.EQ.'SCALAIRE') THEN
  112.         INU2 = 1
  113.         IF (MCHEL2.INFCHE(/2).GE.6) THEN
  114.           INU2 = MCHEL2.INFCHE(1,6)
  115.           IF (INU2.EQ.0) INU2 = 1
  116.         ENDIF
  117.         GOTO 2
  118.       ENDIF
  119.       CALL PLACE(TITNOU,NTIT,INU2,TIT2)
  120.       IF (INU2.EQ.0) THEN
  121.         nc = MCHEL2.ICHAML(/1)
  122. * y a-t'il une unique composante scalaire ?
  123.         DO ic = 1, nc
  124.           MCHAM2 = MCHEL2.ICHAML(ic)
  125.           SEGACT,MCHAM2
  126.           IF (MCHAM2.NOMCHE(/2).NE.1) THEN
  127.             INUK2 = 2
  128.           ELSE
  129.             IF (MCHAM2.NOMCHE(1).NE.'SCAL') INUK2 = 2
  130.           ENDIF
  131.         ENDDO
  132.       ENDIF
  133.  2    CONTINUE
  134. *      write(ioimp,*) 'CHE2',ipche2,'TIT2',tit2,INU2,INUK2
  135.  
  136. * S. PASCAL
  137. * Traitement particulier dans le cas d'un produit de 2 MCHAMLs
  138. * a plusieurs composantes dont certaines sont de type EVOLUTIOn.
  139. * Je cherche dans le MCHEL1 les composantes de type EVOL.
  140. *    Si aucune EVOL, INUJ1=0
  141. *    Si toute EVOL,  INUJ1>0
  142. *    Sinon,          INUJ1<0
  143. * Idem pour MCHEL2 avec INUJ2
  144. * Je me place dans le cas d'un produit composante par composante :
  145.       INUJ1 = 0
  146.       INUJ2 = 0
  147.       IF (INU1.EQ.INU2 .AND. INU1.GT.5) THEN
  148.         nc = MCHEL1.ICHAML(/1)
  149.         NJ1 = 0
  150.         DO ic = 1, nc
  151.           MCHAM1 = MCHEL1.ICHAML(ic)
  152.           SEGACT,MCHAM1
  153.           NJ = MCHAM1.IELVAL(/1)
  154.           DO JELV = 1, NJ
  155.             IF (MCHAM1.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
  156.               INUJ1 = INUJ1 + 1
  157.             ENDIF
  158.           ENDDO
  159.           NJ1 = NJ1 + NJ
  160.         ENDDO
  161. *       IF (INUJ1.GT.0) THEN
  162.           IF (INUJ1.NE.NJ1) INUJ1 = 0 - INUJ1
  163. *       ENDIF
  164.         nc = MCHEL2.ICHAML(/1)
  165.         NJ2 = 0
  166.         DO ic = 1, nc
  167.           MCHAM2 = MCHEL2.ICHAML(ic)
  168.           SEGACT,MCHAM2
  169.           NJ = MCHAM2.IELVAL(/1)
  170.           DO JELV = 1, NJ
  171.             IF (MCHAM2.TYPCHE(JELV).EQ.'POINTEUREVOLUTIO') THEN
  172.               INUJ2 = INUJ2 + 1
  173.             ENDIF
  174.           ENDDO
  175.           NJ2 = NJ2 + NJ
  176.         ENDDO
  177. *       IF (INUJ2.GT.0) THEN
  178.           IF (INUJ2.NE.NJ2) INUJ2 = 0 - INUJ2
  179. *       ENDIF
  180.       ENDIF
  181. *      write(ioimp,*) ' inuj1,inuj2 ',inuj1,inuj2
  182.  
  183.       TITC   = ' '
  184.       NUMCHA = 1
  185.       LPERM  = .FALSE.
  186.       IRET   = 1
  187.  
  188.       IF (INU1.EQ.0.AND.INUK1.EQ.0) THEN
  189.          IF (INU2.LE.1.AND.INUK2.EQ.0) THEN
  190.            KMUL = 1
  191.          ELSE
  192.            KMUL = 2
  193.            LPERM = .TRUE.
  194.          ENDIF
  195.       ELSEIF(INU2.EQ.0.AND.INUK2.EQ.0) THEN
  196.          KMUL = 2
  197.       ELSEIF(INU1.EQ.0.OR.INU2.EQ.0) THEN
  198.          KMUL = 3
  199.       ELSEIF(INU1.EQ.INU2.AND.INU1.LE.5.AND.INU1.GE.1) THEN
  200.          KMUL = 1
  201.       ELSEIF(INU1.EQ.10.AND.INU2.EQ.10) THEN
  202.          TITC   = 'GRADIENT'
  203.          NUMCHA = 8
  204.          KMUL = 5
  205.       ELSEIF(INU1.EQ.10.AND.INU2.EQ.21) THEN
  206.          TITC   = 'GRADIENT'
  207.          NUMCHA = 8
  208.          KMUL = 5
  209.       ELSEIF(INU1.EQ.21.AND.INU2.EQ.10) THEN
  210.          TITC   = 'GRADIENT DE FLEXION'
  211.          NUMCHA = 19
  212.          KMUL = 5
  213.       ELSEIF(INU1.EQ.21.AND.INU2.EQ.21) THEN
  214.          TITC   = 'GRADIENT DE FLEXION'
  215.          NUMCHA = 19
  216.          KMUL = 5
  217.       ELSEIF(INU1.EQ.INU2.AND.INU1.GT.5) THEN
  218.          KMUL = 3
  219.          IF ( (INUJ1.EQ.0.AND.INUJ2.NE.0) .OR.
  220.      &        (INUJ1.LT.0.AND.INUJ2.GT.0) ) THEN
  221.            LPERM = .TRUE.
  222.          ENDIF
  223.       ELSEIF(INU1.EQ.1.AND. INU2.GT.5) THEN
  224.          KMUL = 2
  225.          LPERM = .TRUE.
  226.       ELSEIF(INU2.EQ.1.AND. INU1.GT.5) THEN
  227.          KMUL = 2
  228.       ELSEIF((INU1.EQ.3 .OR. INU1.EQ.6).AND.
  229.      &       (INU2.EQ.13.OR.INU2.EQ.14.OR.INU2.EQ.17)) THEN
  230.          KMUL = 2
  231.          LPERM = .TRUE.
  232.       ELSEIF((INU2.EQ.3 .OR. INU2.EQ.6).AND.
  233.      &       (INU1.EQ.13.OR.INU1.EQ.14.OR.INU1.EQ.17)) THEN
  234.          KMUL = 2
  235.       ELSEIF(INU1.EQ.5 .AND.
  236.      &       (INU2.EQ.11.OR.INU2.EQ.12.OR.
  237.      &        INU2.EQ.15.OR.INU2.EQ.16.OR.INU2.EQ.18)) THEN
  238.          KMUL = 2
  239.          LPERM = .TRUE.
  240.       ELSEIF(INU2.EQ.5 .AND.
  241.      &       (INU1.EQ.11.OR.INU1.EQ.12.OR.
  242.      &        INU1.EQ.15.OR.INU1.EQ.16.OR.INU1.EQ.18)) THEN
  243.          KMUL = 2
  244.       ELSEIF(INU1.EQ.11 .AND. (INU2.EQ.17.OR.INU2.EQ.18)) THEN
  245.          TITC   = 'DEFORMATIONS'
  246.          NUMCHA = 12
  247.          KMUL = 4
  248.       ELSEIF(INU2.EQ.11 .AND. (INU1.EQ.17.OR.INU1.EQ.18)) THEN
  249.          TITC   = 'DEFORMATIONS'
  250.          NUMCHA = 12
  251.          KMUL = 4
  252.          LPERM = .TRUE.
  253.       ELSEIF(INU1.EQ.12 .AND. (INU2.EQ.17.OR.INU2.EQ.18)) THEN
  254.          TITC   = 'CONTRAINTES'
  255.          NUMCHA = 11
  256.          KMUL = 4
  257.       ELSEIF(INU2.EQ.12 .AND. (INU1.EQ.17.OR.INU1.EQ.18)) THEN
  258.          TITC   = 'CONTRAINTES'
  259.          NUMCHA = 11
  260.          KMUL = 4
  261.          LPERM = .TRUE.
  262.       ELSE
  263.          IRET  = 0
  264.          KMUL  = 0
  265.       ENDIF
  266.  
  267. * Permutation des 2 champs :
  268.       IF (LPERM) THEN
  269.         iii    = IPCHE2
  270.         IPCHE2 = IPCHE1
  271.         IPCHE1 = iii
  272.       ENDIF
  273.  
  274. *     ERREUR SI LES MCHAMLS QUE L ON TENTE DE MULTIPLIER
  275. *              OU DIVISER SONT INCOMPATIBLES
  276.       IF (IRET.NE.1) THEN
  277.         MOTERR( 1:16) = TIT1(1:16)
  278.         MOTERR(17:32) = TIT2(1:16)
  279.         CALL ERREUR(993)
  280.       ENDIF
  281.  
  282. *      return
  283.       END
  284.  
  285.  
  286.  

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