Télécharger la plaquette Cast3M


fr en

Télécharger tconvc.eso

Retour à la liste

Numérotation des lignes : 

tconvc

  1. C TCONVC    SOURCE    PV090527  26/04/30    21:16:36     12529          
  2.       SUBROUTINE TCONVC (MRIGID,LPRIMA,IPTD1,NOMPR1,NOMDU1,IPJUCE,
  3.      &                   MPOVA1,IPT1,IPTP1,MPOVA2,NOMFL1,IPTJUN,
  4.      &                   NOSUP1,NOSUD1)
  5. C
  6. C***********************************************************************
  7. C
  8. C FONCTION:
  9. C ---------
  10. C
  11. C     Création de la matrice de RIGIDITE liée à la discrétisation
  12. C     en "0D/1D" sur des éléments de type POINT.
  13. C
  14. C     (appelée par la subroutine TOCONV)
  15. C
  16. C AUTEUR, DATE DE CREATION:
  17. C -------------------------
  18. C
  19. C     Laurent DADA      décembre 1996
  20. C
  21. C
  22. C LANGAGE:
  23. C --------
  24. C
  25. C     ESOPE + FORTRAN77
  26. C
  27. C***********************************************************************
  28. C
  29.       IMPLICIT INTEGER(I-N)
  30.       IMPLICIT REAL*8 (A-H,O-Z)
  31. C
  32.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC CCGEOME
  36. -INC SMCOORD
  37. -INC SMCHPOI
  38. -INC SMELEME
  39.       POINTEUR IPTD1.MELEME,IPTP1.MELEME,IPTJUN.MELEME,IPJUCE.MELEME
  40. -INC SMRIGID
  41. C
  42.       SEGMENT REDI
  43.         INTEGER ORDR1(NNGOT)
  44.         INTEGER ORDR2(NNGOT)
  45.       ENDSEGMENT
  46. C
  47.       CHARACTER*8 NOMPR1,NOMDU1,NOSUP1,NOSUD1
  48.       CHARACTER*8 NOMFL1
  49.       LOGICAL     LPRIMA
  50. C
  51. C Création du support géométrique pour la RIGIDITE
  52. C (maillage de type SUPER-ELEMENT)
  53. C
  54.       NNGOT  = nbpts
  55.       SEGINI REDI
  56.  
  57. C
  58. C S'il n'existe pas de nom de composante PRIMAL ou que les supports des
  59. C composantes PRIMAL et DUAL sont les mêmes, on transforme le
  60. C maillage de POI1 du support de l'inconnue DUAL en un maillage
  61. C de type SUPER-ELEMENT.
  62. C
  63.       SEGACT IPTD1
  64.       IF (IPTD1.ITYPEL.NE.1)   CALL CHANGE (IPTD1,1)
  65.       SEGACT IPTD1
  66. C
  67.       IF ((.NOT.LPRIMA).OR.(NOSUP1.EQ.NOSUD1)) THEN
  68.         NBNN   = IPTD1.NUM(/2)
  69.         NBSOUS = 0
  70.         NBREF  = 0
  71.         NBELEM = 1
  72.         SEGINI MELEME
  73.         ICOLOR(1) = IDCOUL
  74.         ITYPEL    = 28
  75.         DO 40 I40=1,NBNN
  76.           NUM(I40,1)        = IPTD1.NUM(1,I40)
  77.           ORDR1(NUM(I40,1)) = I40
  78.  40     CONTINUE
  79. C
  80. C S'il existe un nom de composante PRIMAL, on fusionne les maillages
  81. C de POI1 des supports des inconnues PRIMAL et DUAL en un maillage
  82. C de type SUPER-ELEMENT.
  83. C
  84.       ELSE
  85.         SEGACT IPTP1
  86.         IF (IPTP1.ITYPEL.NE.1)   CALL CHANGE (IPTP1,1)
  87.         SEGACT IPTP1
  88.         NBNNP1 = IPTP1.NUM(/2)
  89.         NBNND1 = IPTD1.NUM(/2)
  90.         NBNN   = NBNNP1 + NBNND1
  91.         NBSOUS = 0
  92.         NBREF  = 0
  93.         NBELEM = 1
  94.         SEGINI MELEME
  95.         ICOLOR(1) = IDCOUL
  96.         ITYPEL    = 28
  97.         DO 50 I50=1,NBNNP1
  98.           NUM(I50,1) = IPTP1.NUM(1,I50)
  99.           ORDR2(NUM(I50,1)) = I50
  100.  50     CONTINUE
  101.         DO 60 I60=1,NBNND1
  102.           NUM(I60+NBNNP1,1) = IPTD1.NUM(1,I60)
  103. C          ORDR1(NUM(I60+NBNNP1,1)) = I60 + NBNNP1
  104.           ORDR1(NUM(I60+NBNNP1,1)) = I60
  105.  60     CONTINUE
  106.         SEGDES IPTP1
  107.       ENDIF
  108. C
  109.       SEGDES IPTD1
  110. C
  111. C Création de la RIGIDITE
  112. C
  113.       NRIGE  = 7
  114.       NRIGEL = 1
  115.       SEGINI MRIGID
  116.       IPRIGI = MRIGID
  117. C
  118.       MTYMAT = 'RIGIDITE'
  119.       IFORIG = IFOUR
  120.       ICHOLE = 0
  121.       IMGEO1 = 0
  122.       IMGEO2 = 0
  123.       ISUPEQ = 0
  124.       COERIG(1)   = 1.D0
  125.       IRIGEL(1,1) = MELEME
  126.       IRIGEL(2,1) = 0
  127.       IRIGEL(5,1) = NIFOUR
  128.       IRIGEL(6,1) = 0
  129.       IRIGEL(7,1) = 2
  130. C
  131. C Remplissage du descripteur de l'objet RIGIDITE
  132. C
  133.       IF ((LPRIMA).AND.(NOSUP1.NE.NOSUD1)) THEN
  134.         NLIGRP = NBNNP1
  135.         NLIGRD = NBNND1
  136.         SEGINI DESCR
  137.         IRIGEL(3,1) = DESCR
  138.         DO 10 I10=1,NBNNP1
  139.           NOELEP(I10) = I10
  140.           LISINC(I10) = NOMPR1
  141. 10      CONTINUE
  142.         DO 11 I11=1,NBNND1
  143.           NOELED(I11) = I11+NBNNP1
  144.           LISDUA(I11) = NOMDU1
  145. 11      CONTINUE
  146.       ELSE
  147.         NLIGRP = NBNN
  148.         NLIGRD = NBNN
  149.         SEGINI DESCR
  150.         IRIGEL(3,1) = DESCR
  151.         DO 20 I20=1,NBNN
  152.           NOELED(I20) = I20
  153.           LISDUA(I20) = NOMDU1
  154. 20      CONTINUE
  155.         IF (NOSUP1.EQ.NOSUD1) THEN
  156.           DO 21 I21=1,NBNN
  157.             NOELEP(I21) = I21
  158.             LISINC(I21) = NOMPR1
  159. 21        CONTINUE
  160.         ELSE
  161.           DO 22 I22=1,NBNN
  162.             NOELEP(I22) = I22
  163.             LISINC(I22) = NOMDU1
  164. 22        CONTINUE
  165.         ENDIF
  166.       ENDIF
  167. C
  168.       SEGDES DESCR
  169. C
  170.       NELRIG = 1
  171.       rigrel=0
  172.       SEGINI xMATRI
  173. *      SEGINI XMATRI
  174. C
  175. *      IMATTT(1)   = XMATRI
  176.       IRIGEL(4,1) = xMATRI
  177.       xmatri.symre=2
  178. *      SEGDES IMATRI
  179. C
  180. C Remplissage de la matrice élémentaire
  181. C
  182.       SEGACT IPJUCE
  183.       NBEJC1 = IPJUCE.NUM(/2)
  184. C activation du maillage et des valeurs du CHPOINT MULT1
  185.       SEGACT IPT1
  186.       SEGACT MPOVA1
  187. C petit controle du support du champ MULT1
  188.       NBEL1 = IPT1.NUM(/2)
  189.       IF ((.NOT.LPRIMA).OR.(NOSUP1.EQ.NOSUD1)) THEN
  190.         NBTES1 = NBNN
  191.       ELSE
  192.         NBTES1 = NBNND1
  193.       ENDIF
  194.       IF (NBEL1.NE.NBTES1) THEN
  195.         CALL ERREUR (348)
  196.         SEGDES IPT1
  197.         SEGDES MPOVA1
  198.         SEGDES IPJUCE
  199.         SEGSUP MELEME
  200.         SEGSUP XMATRI
  201.         SEGSUP MRIGID
  202.         SEGSUP REDI
  203.         RETURN
  204.       ENDIF
  205. C
  206. C
  207. C       Si la composante PRIMAL n'est pas la composante FLUX
  208. C
  209. C
  210.       IF (NOMPR1.NE.NOMFL1) THEN
  211. C activation du maillage et des valeurs du CHPOINT FLUX
  212.         SEGACT IPTJUN
  213.         SEGACT MPOVA2
  214. C mise à 0.d0 de la matrice élémentaire
  215.         DO 30 I30=1,NBNN
  216.           DO 301 I301=1,NBNN
  217.             RE(I30,I301,1) = 0.D0
  218.  301      CONTINUE
  219.  30     CONTINUE
  220. C balayage sur les SEG3 du maillage des connectivités 'JUNCEL'
  221.         DO 32 I32=1,NBEJC1
  222.           NPT1  = IPJUCE.NUM(1,I32)
  223.           NPTF1 = IPJUCE.NUM(2,I32)
  224.           NPT2  = IPJUCE.NUM(3,I32)
  225. C récupération de la valeur du débit de masse au point NPTF1
  226. C et des valeurs du champ multiplicateur aux points NPT1 et NPT2
  227. C balayage sur les points du CHPOINT FLUX
  228.           XVALF1 = 0.D0
  229.           DO 321 I321=1,NBEJC1
  230.             IF (NPTF1.EQ.(IPTJUN.NUM(1,I321))) THEN
  231.               XVALF1 = MPOVA2.VPOCHA(I321,1)
  232.               GOTO 322
  233.             ENDIF
  234.  321      CONTINUE
  235.  322      CONTINUE
  236. C balayage sur les points du CHPOINT MULT1
  237.           XVALM1 = 0.D0
  238.           XVALM2 = 0.D0
  239.           DO 323 I323=1,NBEL1
  240.         IF (NPT1.EQ.(IPT1.NUM(1,I323))) XVALM1 = MPOVA1.VPOCHA(I323,1)
  241.         IF (NPT2.EQ.(IPT1.NUM(1,I323))) XVALM2 = MPOVA1.VPOCHA(I323,1)
  242.  323      CONTINUE
  243. C quantités disparaissant ou apparaissant dans les deux compartiments
  244.           XMASS1 = -0.5D0 * XVALM1 * XVALF1
  245.           XMASS2 = -0.5D0 * XVALM2 * XVALF1
  246. C positions dans la matrice élémentaire
  247.           IDUA1 = ORDR1(NPT1)
  248.           IDUA2 = ORDR1(NPT2)
  249. C remplissage de la matrice
  250.           RE(IDUA1,IDUA1,1) = RE(IDUA1,IDUA1,1) - XMASS1
  251.           RE(IDUA1,IDUA2,1) = RE(IDUA1,IDUA2,1) - XMASS2
  252.           RE(IDUA2,IDUA1,1) = RE(IDUA2,IDUA1,1) + XMASS1
  253.           RE(IDUA2,IDUA2,1) = RE(IDUA2,IDUA2,1) + XMASS2
  254.  32     CONTINUE
  255.         SEGDES IPTJUN
  256.         SEGDES MPOVA2
  257. C
  258. C
  259.       ELSE
  260. C
  261. C
  262. C mise à 0.d0 de la matrice élémentaire
  263.         DO 70 I70=1,NBNND1
  264.           DO 701 I701=1,NBNNP1
  265.             RE(I70,I701,1) = 0.D0
  266.  701      CONTINUE
  267.  70     CONTINUE
  268. C balayage sur les SEG3 du maillage des connectivités 'JUNCEL'
  269.         DO 72 I72=1,NBEJC1
  270.           NPT1  = IPJUCE.NUM(1,I72)
  271.           NPTF1 = IPJUCE.NUM(2,I72)
  272.           NPT2  = IPJUCE.NUM(3,I72)
  273. C récupération des valeurs du champ multiplicateur aux points NPT1 et NPT2
  274. C balayage sur les points du CHPOINT MULT1
  275.           XVALM1 = 0.D0
  276.           XVALM2 = 0.D0
  277.           DO 723 I723=1,NBEL1
  278.         IF (NPT1.EQ.(IPT1.NUM(1,I723))) XVALM1 = MPOVA1.VPOCHA(I723,1)
  279.         IF (NPT2.EQ.(IPT1.NUM(1,I723))) XVALM2 = MPOVA1.VPOCHA(I723,1)
  280.  723      CONTINUE
  281. C quantité disparaissant ou apparaissant dans le compartiment
  282.           XMASS1 = -0.5D0 * (XVALM1 + XVALM2)
  283. C positions dans la matrice élémentaire
  284.           IDUA1 = ORDR1(NPT1)
  285.           IPRI1 = ORDR2(NPTF1)
  286.           IDUA2 = ORDR1(NPT2)
  287. C remplissage de la matrice
  288.           RE(IDUA1,IPRI1,1) = -1.D0 * XMASS1
  289.           RE(IDUA2,IPRI1,1) =         XMASS1
  290.  72     CONTINUE
  291.       ENDIF
  292. C
  293.       SEGDES IPT1
  294.       SEGDES MPOVA1
  295. C
  296.       SEGDES XMATRI
  297.       SEGDES IPJUCE
  298. C
  299.       SEGDES MELEME
  300. C
  301.       SEGDES MRIGID
  302.       SEGSUP REDI
  303. C
  304.       END
  305.  
  306.  
  307.  
  308.  
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  

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