1 : C TCONVD SOURCE CHAT 09/10/09 21:25:07 6519 2 : SUBROUTINE TCONVD (MRIGID,IPTCEL,LPRIMA,NOMPR1,NOMDU1,IPJUCE, 3 : & MPOVA1,IPT1,IPTJUN,MPOVA2) 4 : C 5 : C*********************************************************************** 6 : C 7 : C FONCTION: 8 : C --------- 9 : C 10 : C Création de la matrice de RIGIDITE liée à la discrétisation 11 : C en "0D/1D" sur des éléments de type POINT. 12 : C 13 : C (appelée par la subroutine TOCONV) 14 : C 15 : C AUTEUR, DATE DE CREATION: 16 : C ------------------------- 17 : C 18 : C Laurent DADA décembre 1996 19 : C 20 : C 21 : C LANGAGE: 22 : C -------- 23 : C 24 : C ESOPE + FORTRAN77 25 : C 26 : C*********************************************************************** 27 : C 28 : IMPLICIT INTEGER(I-N) 29 : IMPLICIT REAL*8 (A-H,O-Z) 30 : C 31 : -INC CCOPTIO 32 : -INC CCGEOME 33 : -INC SMCOORD 34 : -INC SMCHPOI 35 : -INC SMELEME 36 : POINTEUR IPTCEL.MELEME,IPTJUN.MELEME,IPJUCE.MELEME 37 : -INC SMRIGID 38 : C 39 : SEGMENT REDI 40 : INTEGER ORDR1(NNGOT) 41 : ENDSEGMENT 42 : C 43 : CHARACTER*8 TYPE,MOTI,MOT1,NOMPR1,NOMDU1,NOSUP1,NOSUD1,NOMMU1 44 : CHARACTER*7 NAMT1 45 : CHARACTER*8 NOMFL1,NOSUF1 46 : LOGICAL LPRIMA 47 : C 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 : C 55 : C On transforme le maillage de POI1 du support de l'inconnue CELL 56 : C en un maillage de type SUPER-ELEMENT. 57 : C 58 : SEGACT IPTCEL 58 : IF (IPTCEL.ITYPEL.NE.1) CALL CHANGE (IPTCEL,1) 59 : SEGACT IPTCEL 60 : C 61 : NBNN = IPTCEL.NUM(/2) 62 : NBSOUS = 0 63 : NBREF = 0 64 : NBELEM = 1 65 : SEGINI MELEME 66 : ICOLOR(1) = IDCOUL 67 : ITYPEL = 28 68 : DO 40 I40=1,NBNN 69 : NUM(I40,1) = IPTCEL.NUM(1,I40) 70 : ORDR1(NUM(I40,1)) = I40 71 : 40 CONTINUE 72 : C 73 : SEGDES IPTCEL 74 : C 75 : C Création de la RIGIDITE 76 : C 77 : NRIGE = 7 78 : NRIGEL = 1 79 : SEGINI MRIGID 80 : IPRIGI = MRIGID 81 : C 82 : MTYMAT = 'RIGIDITE' 83 : IFORIG = IFOMOD 84 : ICHOLE = 0 85 : IMGEO1 = 0 86 : IMGEO2 = 0 87 : ISUPEQ = 0 88 : COERIG(1) = 1.D0 89 : IRIGEL(1,1) = MELEME 90 : IRIGEL(2,1) = 0 91 : IRIGEL(5,1) = NIFOUR 92 : IRIGEL(6,1) = 0 93 : IRIGEL(7,1) = 2 94 : C 95 : C Remplissage du descripteur de l'objet RIGIDITE 96 : C 97 : IF (LPRIMA) THEN 98 : NLIGRP = NBNN 99 : NLIGRD = NBNN 100 : SEGINI DESCR 101 : IRIGEL(3,1) = DESCR 102 : DO 10 I10=1,NBNN 103 : NOELEP(I10) = I10 104 : LISINC(I10) = NOMPR1 105 : 10 CONTINUE 106 : DO 11 I11=1,NBNN 107 : NOELED(I11) = I11 108 : LISDUA(I11) = NOMDU1 109 : 11 CONTINUE 110 : ELSE 111 : NLIGRP = NBNN 112 : NLIGRD = NBNN 113 : SEGINI DESCR 114 : IRIGEL(3,1) = DESCR 115 : DO 20 I20=1,NBNN 116 : NOELEP(I20) = I20 117 : LISINC(I20) = NOMDU1 118 : NOELED(I20) = I20 119 : LISDUA(I20) = NOMDU1 120 : 20 CONTINUE 121 : ENDIF 122 : C 123 : SEGDES DESCR 124 : C 125 : NELRIG = 1 126 : * SEGINI IMATRI 127 : SEGINI XMATRI 128 : C 129 : * IMATTT(1) = XMATRI 130 : IRIGEL(4,1) = xMATRI 131 : * SEGDES IMATRI 132 : C 133 : C Remplissage de la matrice élémentaire 134 : C 135 : SEGACT IPJUCE 136 : NBEJC1 = IPJUCE.NUM(/2) 137 : C activation du maillage et des valeurs du CHPOINT MULT1 138 : SEGACT IPT1 139 : SEGACT MPOVA1 140 : C petit controle du support du champ MULT1 141 : NBEL1 = IPT1.NUM(/2) 142 : IF (NBEL1.NE.NBNN) THEN 142 : CALL ERREUR (348) 143 : SEGDES IPT1 144 : SEGDES MPOVA1 145 : SEGDES IPJUCE 146 : SEGSUP MELEME 147 : SEGSUP XMATRI 148 : SEGSUP MRIGID 149 : SEGSUP REDI 150 : RETURN 151 : ENDIF 152 : C 153 : C 154 : C 155 : C activation du maillage et des valeurs du CHPOINT FLUX 156 : SEGACT IPTJUN 157 : NBNNJU = IPTJUN.NUM(/2) 158 : SEGACT MPOVA2 159 : C mise à 0.d0 de la matrice élémentaire 160 : DO 30 I30=1,NBNN 161 : DO 301 I301=1,NBNN 162 : RE(I30,I301,1) = 0.D0 163 : 301 CONTINUE 164 : 30 CONTINUE 165 : C 166 : C balayage sur les SEG3 du maillage des connectivités 'JUNCEL' 167 : DO 32 I32=1,NBEJC1 168 : NPT1 = IPJUCE.NUM(1,I32) 169 : NPTF1 = IPJUCE.NUM(2,I32) 170 : NPT2 = IPJUCE.NUM(3,I32) 171 : C récupération de la valeur du débit de masse au point NPTF1 172 : C et des valeurs du champ multiplicateur aux points NPT1 et NPT2 173 : C balayage sur les points du CHPOINT FLUX 174 : XVALF1 = 0.D0 175 : DO 321 I321=1,NBNNJU 176 : IF (NPTF1.EQ.(IPTJUN.NUM(1,I321))) THEN 177 : XVALF1 = MPOVA2.VPOCHA(I321,1) 178 : GOTO 322 179 : ENDIF 180 : 321 CONTINUE 181 : 322 CONTINUE 182 : C balayage sur les points du CHPOINT MULT1 183 : XVALM1 = 0.D0 184 : XVALM2 = 0.D0 185 : DO 323 I323=1,NBEL1 186 : IF (NPT1.EQ.(IPT1.NUM(1,I323))) XVALM1 = MPOVA1.VPOCHA(I323,1) 187 : IF (NPT2.EQ.(IPT1.NUM(1,I323))) XVALM2 = MPOVA1.VPOCHA(I323,1) 188 : 323 CONTINUE 189 : C quantités disparaissant ou apparaissant dans les deux compartiments 190 : XMASS1 = 0.5D0 * XVALM1 * (ABS(XVALF1)+XVALF1) 191 : XMASS2 = 0.5D0 * XVALM2 * (ABS(XVALF1)-XVALF1) 192 : C positions dans la matrice élémentaire 193 : IDUA1 = ORDR1(NPT1) 194 : IDUA2 = ORDR1(NPT2) 195 : C remplissage de la matrice 196 : RE(IDUA1,IDUA1,1) = RE(IDUA1,IDUA1,1) + XMASS1 197 : RE(IDUA1,IDUA2,1) = -1.D0 * XMASS2 198 : RE(IDUA2,IDUA1,1) = -1.D0 * XMASS1 199 : RE(IDUA2,IDUA2,1) = RE(IDUA2,IDUA2,1) + XMASS2 200 : 32 CONTINUE 201 : C 202 : SEGDES IPTJUN 203 : SEGDES MPOVA2 204 : C 205 : SEGDES IPT1 206 : SEGDES MPOVA1 207 : C 208 : SEGDES XMATRI 209 : SEGDES IPJUCE 210 : C 211 : SEGDES MELEME 212 : C 213 : SEGDES MRIGID 214 : SEGSUP REDI 215 : C 216 : END 217 : 218 :
© Cast3M 2003 - All rights reserved.
Disclaimer