1 : C CAPA1 SOURCE CHAT 12/06/07 21:15:04 7389 2 : 3 : C======================================================================= 4 : C= C A P A 1 = 5 : C= --------- = 6 : C= = 7 : C= Fonction : = 8 : C= ---------- = 9 : C= Calcul de la matrice de CAPACITE CALORIFIQUE (type RIGIDITE) = 10 : C= = 11 : C= Parametres : (E)=Entree (S)=Sortie = 12 : C= ------------ = 13 : C= IPMODE (E) Segment IMODEL pour un modele elementaire (ACTIF) = 14 : C= IPCHEL (E) Segment MCHELM de CARACTERISTIQUES (?) = 15 : C= ISUPC (E) Support du champ de CARACTERISTIQUES = 16 : C= ITABCP (E) TABLE pour le changement de PHASE = 17 : C= IPRIGI (E/S) Segment MRIGID : CAPACITE (ACTIF) = 18 : C= = 19 : C= Creation par Denis ROBERT le 15 fevrier 1988. = 20 : C= Modifications par DEGAY le 10 mai 1994 et ulterieurement. = 21 : C======================================================================= 22 : 23 : SUBROUTINE CAPA1 (IPMODE,IPCHEL,ISUPC,ITABCP, IPRIGI) 24 : 25 : IMPLICIT INTEGER(I-N) 26 : IMPLICIT REAL*8 (A-H,O-Z) 27 : 28 : -INC CCOPTIO 29 : -INC CCHAMP 30 : -INC CCREEL 31 : 32 : -INC SMELEME 33 : -INC SMINTE 34 : -INC SMMODEL 35 : -INC SMRIGID 36 : 37 : INTEGER OOOVAL 38 : 39 : SEGMENT NOTYPE 40 : CHARACTER*16 TYPE(NBTYPE) 41 : ENDSEGMENT 42 : 43 : SEGMENT MPTVAL 44 : INTEGER IPOS(NS),NSOF(NS), IVAL(NCOSOU) 45 : CHARACTER*16 TYVAL(NCOSOU) 46 : ENDSEGMENT 47 : 48 : CHARACTER*8 CMATE 49 : CHARACTER*(LCONMO) CONM 50 : 51 : PARAMETER ( NINF=3 ) 52 : DIMENSION INFOS(NINF) 53 : 54 : C= LEFMAS Liste des numeros d'elements finis MASSIFs implementes 55 : C= NEFMAS Longueur de cette liste = 56 : C= LEFCOQ Liste des numeros d'elements finis COQUEs implementes 57 : C= NEFCOQ Longueur de cette liste = 58 : PARAMETER (NEFMAS=14, NEFCOQ=5,neftuy=2) 59 : DIMENSION LEFMAS(NEFMAS), LEFCOQ(NEFCOQ),leftuy(neftuy) 60 : 61 : C Elements TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15 TET4 62 : C MASSIFs TE10 PYR5 PY13 T1D2 T1D3 63 : DATA LEFMAS / 4, 6, 8, 10, 14, 15, 16, 17, 23, 64 : & 24, 25, 26, 191, 192 / 65 : C COQUEs COQ2 COQ3 COQ6 COQ4 COQ8 66 : DATA LEFCOQ / 44, 27, 56, 49, 41 / 67 : C Tuyau(pour advection) 68 : C TUY2 TUY3 69 : DATA leftuy/ 269 , 270/ 70 : 71 : IPINTE = 0 72 : IPINT2 = 0 73 : MOMATE = 0 74 : MOTYPE = 0 75 : IPCPHA = 0 76 : MOCPHA = 0 77 : 78 : C- Matrice de capacite 79 : MRIGID = IPRIGI 80 : c* SEGACT,MRIGID 81 : NRIGE0 = IRIGEL(/2) 82 : 83 : C- Recuperation du sous-modele et de la zone elementaire associee 84 : IMODEL = IPMODE 85 : C* SEGACT,IMODEL 86 : 87 : NEF = NEFMOD 88 : IF (NEF.EQ.22) RETURN 89 : 90 : IMAS = 0 90 : CALL PLACE2(LEFMAS,NEFMAS,IMAS,NEF) 91 : ICOQ = 0 91 : CALL PLACE2(LEFCOQ,NEFCOQ,ICOQ,NEF) 92 : ituy=0 92 : CALL PLACE2(LEFTUY,NEFTUY,ituy,NEF) 93 : C- Recuperation d'informations sur le maillage elementaire 94 : IPT1 = IMAMOD 95 : SEGACT,IPT1 96 : NBNOE1 = IPT1.NUM(/1) 97 : NBELE1 = IPT1.NUM(/2) 98 : 99 : C- Quelques informations sur le modele 100 : CONM = CONMOD 101 : CMATE = CMATEE 102 : MATE = IMATEE 103 : 104 : IRET = 1 104 : CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET) 105 : IF (IRET.EQ.0) GOTO 9990 106 : 107 : C- Recuperation d'informations sur l'element fini 107 : CALL TSHAPE(NEF,'GAUSS',IPINTE) 108 : IF (IERR.NE.0) GOTO 9990 109 : MINTE = IPINTE 110 : SEGACT,MINTE 111 : IF (ICOQ.NE.0) THEN 112 : IF (NEF.EQ.56 .OR. NEF.EQ.41 .OR. NEF.EQ.49) THEN 112 : CALL TSHAPE(NEF,'NOEUD',IPINT2) 113 : MINTE2 = IPINT2 114 : SEGACT,MINTE2 115 : ENDIF 116 : ENDIF 117 : 118 : C- Recuperation des caracteristiques materielles (obligatoires) 119 : nbrobl = 2 120 : nbrfac = 0 121 : IF (NEF.EQ.46 .OR. ICOQ.NE.0.or.ituy.ne.0) THEN 122 : nbrobl = 3 123 : ENDIF 124 : SEGINI,nomid 125 : lesobl(1) = 'RHO ' 126 : lesobl(2) = 'C ' 127 : IF (NEF.EQ.46.or.ituy.ne.0) THEN 128 : lesobl(nbrobl) = 'SECT' 129 : ELSE IF (ICOQ.NE.0) THEN 130 : lesobl(nbrobl) = 'EPAI' 131 : ENDIF 132 : NMATT = nbrobl + nbrfac 133 : MOMATE = nomid 134 : c 135 : nbtype = 1 136 : SEGINI,notype 137 : type(1) = 'REAL*8' 138 : MOTYPE = notype 139 : 140 : C- Recuperation de donnees dans le cas d'un CHANGEMENT DE PHASE 141 : C Dans le cas d'un changement de phase, on calcule une capacite 142 : C calorifique equivalente liee a la chaleur latente (MCHAML IPCPHA). 143 : C Le support de ce champ est celui des points de GAUSS (IPINTE). 144 : IF (ITABCP.NE.0) THEN 144 : CALL CAPA7(ITABCP,IPT1,ICOQ,IPINTE, IPCPHA) 145 : IF (IERR.NE.0) GOTO 9990 146 : nbrobl = 1 147 : nbrfac = 0 148 : SEGINI,nomid 149 : lesobl(1) = 'C ' 150 : MOCPHA = nomid 151 : NPHAT = nbrobl + nbrfac 152 : ENDIF 153 : 154 : C- Definition du descripteur IDESCR pour le modele elementaire 155 : IDESCR = 0 155 : CALL TCOND2(ICOQ,NBNOE1,IDESCR) 156 : DESCR = IDESCR 157 : SEGACT,DESCR 158 : NLIGRD = LISDUA(/2) 159 : NLIGRP = LISINC(/2) 160 : SEGDES,DESCR 161 : LRE = NLIGRD 162 : 163 : C- Partionnement si necessaire de la matrice de capacite 164 : C- determinant ainsi le nombre d'objets elementaires de MRIGID 165 : LTRK = oooval(1,4) 166 : IF (LTRK.EQ.0) LTRK = oooval(1,1) 167 : * Ajout a la taille en mots de la matrice des infos du segment 168 : LSEG = LRE*LRE*NBELE1 + 16 169 : NBLPRT = (LSEG-1)/LTRK + 1 170 : NBLMAX = (NBELE1-1)/NBLPRT + 1 171 : NBLPRT = (NBELE1-1)/NBLMAX + 1 172 : * write(ioimp,*) ' capa1 : nblprt nblmax = ',nblprt,nblmax,nbele1 173 : 174 : C Ajout de la matrice de CAPACITE a la matrice globale 175 : C ==================================================== 176 : NRIGEL = NRIGE0 + NBLPRT 177 : SEGADJ,MRIGID 178 : 179 : descr = IDESCR 180 : meleme = IPT1 181 : nbnn = NBNOE1 182 : nbelem = NBELE1 183 : nbsous = 0 184 : nbref = 0 185 : 186 : C Boucle sur les PARTITIONS elementaires de la matrice 187 : C ==================================================== 188 : DO irige = 1, NBLPRT 189 : 190 : IVAMAT = 0 191 : IVAPHA = 0 192 : 193 : IF (NBLPRT.GT.1) THEN 194 : C- Partitionnement du maillage support de la matrice elementaire 195 : SEGACT,IPT1 196 : ielem = (irige-1)*NBLMAX 197 : nbelem = MIN(NBLMAX,NBELE1-ielem) 198 : * write(ioimp,*) ' creation segment ',nbnn,nbelem 199 : SEGINI,meleme 200 : itypel = IPT1.itypel 201 : DO ielt = 1, nbelem 202 : jelt = ielt + ielem 203 : DO inoe = 1, nbnn 204 : num(inoe,ielt) = IPT1.NUM(inoe,jelt) 205 : ENDDO 206 : icolor(ielt) = IPT1.ICOLOR(jelt) 207 : ENDDO 208 : C- Recopie du descripteur 209 : des1 = IDESCR 210 : SEGINI,descr=des1 211 : SEGDES,descr 212 : ENDIF 213 : ipmail = meleme 214 : ipdesc = descr 215 : 216 : C- Initialisation de la matrice de rigidite elementaire (xmatri) 217 : NELRIG = nbelem 218 : SEGINI,xmatri 219 : ipmatr = xmatri 220 : 221 : C- Recuperation des valeurs de caracteristiques sur la partition 221 : CALL KOMCHA(IPCHEL,ipmail,CONM,MOMATE,MOTYPE,1,INFOS,3,IVAMAT) 222 : IF (IERR.NE.0) GOTO 9991 223 : IF (ISUPC.EQ.1) THEN 223 : CALL VALCHE(IVAMAT,NMATT,IPINTE,0) 224 : IF (IERR.NE.0) THEN 225 : ISUPC = 0 226 : GOTO 9991 227 : ENDIF 228 : ENDIF 229 : C- Idem pour capacite equivalente en cas de changement de phase 230 : IF (ITABCP.NE.0) THEN 230 : CALL KOMCHA(IPCPHA,ipmail,CONM,MOCPHA,MOTYPE,1,INFOS,3,IVAPHA) 231 : IF (IERR.NE.0) GOTO 9991 232 : ENDIF 233 : C- Calcul de la matrice elementaire pour la paritition elementaire et 234 : C Remplissage de la matrice globale (IPRIGI) 235 : C---> Elements MASSIFs a integration NUMERIQUE 236 : IF (IMAS.NE.0) THEN 236 : CALL CAPANU(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT, 237 : & ipmatr,LRE) 238 : C---> Elements de COQUEs 239 : ELSE IF (ICOQ.NE.0) THEN 240 : C-----> Element COQ2 (axisymetrique) 241 : IF (NEF.EQ.44) THEN 241 : CALL CAPAC1(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT, 242 : & ipmatr,LRE) 243 : C-----> Element COQ3 244 : ELSE IF (NEF.EQ.27) THEN 244 : CALL CAPAC3(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT, 245 : & ipmatr,LRE) 246 : C-----> Elements COQ4, COQ6 et COQ8 247 : C* ELSE IF (NEF.EQ.56 .OR. NEF.EQ.41 .OR. NEF.EQ.49) THEN 248 : ELSE 248 : CALL CAPAC2(NEF,ipmail,IPINTE,IPINT2,IVAMAT,NMATT, 249 : & IVAPHA,NPHAT, ipmatr,LRE) 250 : ENDIF 251 : C---> Element BARRE (integration NUMERIQUE) 252 : ELSE IF (NEF.EQ.46.or.nef.eq.269.or.nef.eq.270) THEN 252 : CALL CAPABA(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT, 253 : & ipmatr,LRE) 254 : C---> Elements seg3, RAC2 et RAC3 : non implementes 255 : ELSE IF (NEF.EQ.3 .OR. NEF.EQ.12 .OR. NEF.EQ.13) THEN 255 : CALL ERREUR(251) 256 : C---> Option indisponible : ERREUR 257 : ELSE 257 : CALL ERREUR(19) 258 : ENDIF 259 : 260 : C- Un peu de menage dans les segments 261 : 9991 CONTINUE 262 : IF (ISUPC.EQ.1 .OR. NBLPRT.NE.1) THEN 262 : CALL DTMVAL(IVAMAT,3) 263 : ELSE 263 : CALL DTMVAL(IVAMAT,1) 264 : ENDIF 265 : IF (ITABCP.NE.0) THEN 266 : IF (NBLPRT.NE.1) THEN 266 : CALL DTMVAL(IVAPHA,3) 267 : ELSE 267 : CALL DTMVAL(IVAPHA,1) 268 : ENDIF 269 : ENDIF 270 : C- Sortie prematuree en cas d'erreur 271 : IF (IERR.NE.0) GOTO 9990 272 : 273 : xmatri = ipmatr 274 : SEGDES,xmatri 275 : IF (NBLPRT.NE.1) THEN 276 : meleme = ipmail 277 : SEGDES,meleme 278 : ENDIF 279 : 280 : C- Stockage de la matrice de CAPACITE du modele 281 : jrige = NRIGE0 + irige 282 : COERIG(jrige) = 1. 283 : IRIGEL(1,jrige) = ipmail 284 : IRIGEL(2,jrige) = 0 285 : IRIGEL(3,jrige) = ipdesc 286 : IRIGEL(4,jrige) = ipmatr 287 : IRIGEL(5,jrige) = NIFOUR 288 : IRIGEL(6,jrige) = 0 289 : IRIGEL(7,jrige) = 0 290 : IRIGEL(8,jrige) = 0 291 : 292 : ENDDO 293 : 294 : IPRIGI = MRIGID 295 : 296 : C MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS 297 : C ============================================== 298 : 9990 CONTINUE 299 : SEGDES,IPT1 300 : IF (IPINTE.NE.0) THEN 301 : MINTE = IPINTE 302 : SEGDES,MINTE 303 : ENDIF 304 : IF (IPINT2.NE.0) THEN 305 : MINTE = IPINT2 306 : SEGDES,MINTE 307 : ENDIF 308 : IF (MOMATE.NE.0) THEN 309 : nomid = MOMATE 310 : SEGSUP,nomid 311 : ENDIF 312 : IF (MOTYPE.NE.0) THEN 313 : notype = MOTYPE 314 : SEGSUP,notype 315 : ENDIF 316 : IF (MOCPHA.NE.0) THEN 317 : nomid = MOCPHA 318 : SEGSUP,nomid 319 : ENDIF 320 : IF (IPCPHA.NE.0) THEN 320 : CALL DTCHAM(IPCPHA) 321 : ENDIF 322 : 323 : RETURN 324 : END 325 : 326 : 327 :
© Cast3M 2003 - All rights reserved.
Disclaimer