Esope source files

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