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    FANDEUR   22/01/03    21:15:49     11237          
  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.       SEGINI xMATRI
  172. *      SEGINI XMATRI
  173. C
  174. *      IMATTT(1)   = XMATRI
  175.       IRIGEL(4,1) = xMATRI
  176.       xmatri.symre=2
  177. *      SEGDES IMATRI
  178. C
  179. C Remplissage de la matrice élémentaire
  180. C
  181.       SEGACT IPJUCE
  182.       NBEJC1 = IPJUCE.NUM(/2)
  183. C activation du maillage et des valeurs du CHPOINT MULT1
  184.       SEGACT IPT1
  185.       SEGACT MPOVA1
  186. C petit controle du support du champ MULT1
  187.       NBEL1 = IPT1.NUM(/2)
  188.       IF ((.NOT.LPRIMA).OR.(NOSUP1.EQ.NOSUD1)) THEN
  189.         NBTES1 = NBNN
  190.       ELSE
  191.         NBTES1 = NBNND1
  192.       ENDIF
  193.       IF (NBEL1.NE.NBTES1) THEN
  194.         CALL ERREUR (348)
  195.         SEGDES IPT1
  196.         SEGDES MPOVA1
  197.         SEGDES IPJUCE
  198.         SEGSUP MELEME
  199.         SEGSUP XMATRI
  200.         SEGSUP MRIGID
  201.         SEGSUP REDI
  202.         RETURN
  203.       ENDIF
  204. C
  205. C
  206. C       Si la composante PRIMAL n'est pas la composante FLUX
  207. C
  208. C
  209.       IF (NOMPR1.NE.NOMFL1) THEN
  210. C activation du maillage et des valeurs du CHPOINT FLUX
  211.         SEGACT IPTJUN
  212.         SEGACT MPOVA2
  213. C mise à 0.d0 de la matrice élémentaire
  214.         DO 30 I30=1,NBNN
  215.           DO 301 I301=1,NBNN
  216.             RE(I30,I301,1) = 0.D0
  217.  301      CONTINUE
  218.  30     CONTINUE
  219. C balayage sur les SEG3 du maillage des connectivités 'JUNCEL'
  220.         DO 32 I32=1,NBEJC1
  221.           NPT1  = IPJUCE.NUM(1,I32)
  222.           NPTF1 = IPJUCE.NUM(2,I32)
  223.           NPT2  = IPJUCE.NUM(3,I32)
  224. C récupération de la valeur du débit de masse au point NPTF1
  225. C et des valeurs du champ multiplicateur aux points NPT1 et NPT2
  226. C balayage sur les points du CHPOINT FLUX
  227.           XVALF1 = 0.D0
  228.           DO 321 I321=1,NBEJC1
  229.             IF (NPTF1.EQ.(IPTJUN.NUM(1,I321))) THEN
  230.               XVALF1 = MPOVA2.VPOCHA(I321,1)
  231.               GOTO 322
  232.             ENDIF
  233.  321      CONTINUE
  234.  322      CONTINUE
  235. C balayage sur les points du CHPOINT MULT1
  236.           XVALM1 = 0.D0
  237.           XVALM2 = 0.D0
  238.           DO 323 I323=1,NBEL1
  239.         IF (NPT1.EQ.(IPT1.NUM(1,I323))) XVALM1 = MPOVA1.VPOCHA(I323,1)
  240.         IF (NPT2.EQ.(IPT1.NUM(1,I323))) XVALM2 = MPOVA1.VPOCHA(I323,1)
  241.  323      CONTINUE
  242. C quantités disparaissant ou apparaissant dans les deux compartiments
  243.           XMASS1 = -0.5D0 * XVALM1 * XVALF1
  244.           XMASS2 = -0.5D0 * XVALM2 * XVALF1
  245. C positions dans la matrice élémentaire
  246.           IDUA1 = ORDR1(NPT1)
  247.           IDUA2 = ORDR1(NPT2)
  248. C remplissage de la matrice
  249.           RE(IDUA1,IDUA1,1) = RE(IDUA1,IDUA1,1) - XMASS1
  250.           RE(IDUA1,IDUA2,1) = RE(IDUA1,IDUA2,1) - XMASS2
  251.           RE(IDUA2,IDUA1,1) = RE(IDUA2,IDUA1,1) + XMASS1
  252.           RE(IDUA2,IDUA2,1) = RE(IDUA2,IDUA2,1) + XMASS2
  253.  32     CONTINUE
  254.         SEGDES IPTJUN
  255.         SEGDES MPOVA2
  256. C
  257. C
  258.       ELSE
  259. C
  260. C
  261. C mise à 0.d0 de la matrice élémentaire
  262.         DO 70 I70=1,NBNND1
  263.           DO 701 I701=1,NBNNP1
  264.             RE(I70,I701,1) = 0.D0
  265.  701      CONTINUE
  266.  70     CONTINUE
  267. C balayage sur les SEG3 du maillage des connectivités 'JUNCEL'
  268.         DO 72 I72=1,NBEJC1
  269.           NPT1  = IPJUCE.NUM(1,I72)
  270.           NPTF1 = IPJUCE.NUM(2,I72)
  271.           NPT2  = IPJUCE.NUM(3,I72)
  272. C récupération des valeurs du champ multiplicateur aux points NPT1 et NPT2
  273. C balayage sur les points du CHPOINT MULT1
  274.           XVALM1 = 0.D0
  275.           XVALM2 = 0.D0
  276.           DO 723 I723=1,NBEL1
  277.         IF (NPT1.EQ.(IPT1.NUM(1,I723))) XVALM1 = MPOVA1.VPOCHA(I723,1)
  278.         IF (NPT2.EQ.(IPT1.NUM(1,I723))) XVALM2 = MPOVA1.VPOCHA(I723,1)
  279.  723      CONTINUE
  280. C quantité disparaissant ou apparaissant dans le compartiment
  281.           XMASS1 = -0.5D0 * (XVALM1 + XVALM2)
  282. C positions dans la matrice élémentaire
  283.           IDUA1 = ORDR1(NPT1)
  284.           IPRI1 = ORDR2(NPTF1)
  285.           IDUA2 = ORDR1(NPT2)
  286. C remplissage de la matrice
  287.           RE(IDUA1,IPRI1,1) = -1.D0 * XMASS1
  288.           RE(IDUA2,IPRI1,1) =         XMASS1
  289.  72     CONTINUE
  290.       ENDIF
  291. C
  292.       SEGDES IPT1
  293.       SEGDES MPOVA1
  294. C
  295.       SEGDES XMATRI
  296.       SEGDES IPJUCE
  297. C
  298.       SEGDES MELEME
  299. C
  300.       SEGDES MRIGID
  301.       SEGSUP REDI
  302. C
  303.       END
  304.  
  305.  
  306.  
  307.  
  308.  
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  

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