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

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