1 : C TADVE1 SOURCE CHAT 12/06/07 21:16:04 7389 2 : 3 : ************************************************************************ 4 : * 5 : * T A D V E 1 6 : * ----------- 7 : * 8 : * FONCTION: 9 : * --------- 10 : * CREATION DE LA MATRICE DE ADVECTION 11 : * GESTION DES SEGMENTS ET TESTS DE COMPATIBILITE 12 : * 13 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 14 : * ----------- 15 : * IPMODE (E) POINTEUR SUR LE SEGMENT MMODEL 16 : * IPCHEL (E) POINTEUR SUR LE SEGMENT MCHELM 17 : * IPRIGI (S) POINTEUR SUR LE SEGMENT MRIGID 18 : * 19 : * AUTEUR, DATE DE CREATION: 20 : * ------------------------- 21 : * MARINO ARROYO, 18 MAI 1999 22 : * 23 : * LANGAGE: 24 : * -------- 25 : * ESOPE + FORTRAN77 26 : * 27 : ************************************************************************ 28 : * 29 : SUBROUTINE TADVE1 (IPMODE,IPCHEL,IPRIGI,ISYMM) 30 : 31 : IMPLICIT INTEGER(I-N) 32 : IMPLICIT REAL*8(A-H,O-Z) 33 : 34 : -INC CCOPTIO 35 : -INC CCHAMP 36 : 37 : -INC SMCHAML 38 : -INC SMELEME 39 : -INC SMINTE 40 : -INC SMMODEL 41 : POINTEUR nomid1.NOMID 42 : -INC SMRIGID 43 : 44 : INTEGER OOOVAL 45 : 46 : SEGMENT NOTYPE 47 : CHARACTER*16 TYPE(NBTYPE) 48 : ENDSEGMENT 49 : 50 : SEGMENT MPTVAL 51 : INTEGER IPOS(NS),NSOF(NS), IVAL(NCOSOU) 52 : CHARACTER*16 TYVAL(NCOSOU) 53 : ENDSEGMENT 54 : 55 : PARAMETER ( NINF=3 ) 56 : INTEGER INFOS(NINF) 57 : 58 : CHARACTER*8 CMATE 59 : CHARACTER*(LCONMO) CONM 60 : CHARACTER*10 PEAU 61 : 62 : PARAMETER ( LNUCOQ=5 , LINUM=12 , LINUC=12 ) 63 : INTEGER INUCOQ(LNUCOQ), INUMA(LINUM), INUCO(LINUC) 64 : * 65 : * TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15 66 : DATA INUMA/ 4, 6, 8, 10, 14, 15, 16, 17, 67 : * TET4 TET10 PYR5 PY13 68 : & 23, 24, 25, 26/ 69 : * SEG2 SEG3 TRI3 TRI6 QUA4 QUA8 70 : DATA INUCO / 2, 3, 4, 6, 8, 10, 71 : * RAC2 RAC3 LIA3 LIA6 LIA4 LIA8 72 : & 12, 13, 18, 19, 20, 21 / 73 : * COQ2 COQ3 COQ6 COQ4 COQ8 74 : DATA INUCOQ / 44 , 27 , 56 , 49 ,41 / 75 : 76 : IPRIGI = 0 77 : C--- 78 : C Verification du lieu support du MCHAML de caracteristiques 79 : C--- 79 : CALL QUESUP(IPMODE,IPCHEL,6,0,ISUPCH,IRET) 80 : IF (ISUPCH.GT.1) RETURN 81 : C--- 82 : C Activation du MODELE 83 : C--- 84 : MMODEL = IPMODE 85 : SEGACT,MMODEL 86 : * selection de la partie advection 86 : call selmod(mmodel,ipmo,'ADVECTION') 87 : mmodel=ipmo 88 : NBMAIL = KMODEL(/1) 89 : if( nbmail.eq.0) then 89 : call erreur (19) 90 : return 91 : endif 92 : C--- 93 : C Initialisation de la matrice d'ADVECTION (chapeau de l'objet RIGIDITE) 94 : C--- 95 : NRIGEL = 0 96 : SEGINI,MRIGID 97 : MTYMAT = 'RIGIDITE' 98 : ICHOLE = 0 99 : IMGEO1 = 0 100 : IMGEO2 = 0 101 : C* IFORIG = IFOMOD 102 : IFORIG = IFOUR 103 : ISUPEQ = 0 104 : 105 : C--- 106 : C BOUCLE SUR LES MODELES ELEMENTAIRES 107 : C--- 108 : DO 10 IMAIL = 1, NBMAIL 109 : 110 : IPINTE = 0 111 : IPINT1 = 0 112 : MOMATE = 0 113 : MOTYPE = 0 114 : 115 : C- Recuperation du sous-modele et de la zone elementaire associee 116 : IMODEL = KMODEL(IMAIL) 117 : SEGACT,IMODEL 118 : 119 : C- Recuperation d'informations sur le maillage elementaire 120 : IPT1 = IMAMOD 121 : SEGACT,IPT1 122 : NBNOE1 = IPT1.NUM(/1) 123 : NBELE1 = IPT1.NUM(/2) 124 : ituy=0 125 : if(nefmod.eq.269.or.nefmod.eq.270) ituy=1 126 : C- Quelques informations et verifications sur le modele elementaire 127 : CONM = CONMOD 128 : CMATE = CMATEE 129 : MATE = IMATEE 130 : 131 : NF1 = FORMOD(/2) 131 : CALL PLACE(FORMOD,NF1,IF1,'CONVECTION') 131 : CALL PLACE(FORMOD,NF1,IF2,'THERMIQUE') 132 : C Autre formulation que 'THERMIQUE' ou 'CONVECTION' => Indisponible 133 : IF ( (IF1.EQ.0.AND.IF2.EQ.0) .OR. 134 : & (IF1.NE.0.AND.IF2.NE.0) ) THEN 134 : CALL ERREUR(251) 135 : GOTO 1999 136 : ENDIF 137 : C Formulation 'CONVECTION' => Indisponible 138 : IF (IF1.NE.0) THEN 138 : CALL ERREUR(251) 139 : GOTO 1999 140 : ENDIF 141 : 142 : C Seule l'isotropie est disponible en 2D PLAN et AXISYMETRIQUE 143 : if(ituy.ne.1) then 144 : IF (MATE.EQ.1) THEN 145 : IF (IFOMOD.GT.0) THEN 146 : WRITE(IOIMP,*) '### ERREUR DANS ADVE : ', 147 : & 'SEULEMENT LE CAS 2D EST ENVISAGE' 147 : CALL ERREUR(19) 148 : GOTO 1999 149 : ENDIF 150 : ELSE 151 : WRITE(IOIMP,*) '### ERREUR DANS ADVE : ', 152 : & 'SEULEMENT LE CAS ISOTROPE EST ENVISAGE' 152 : CALL ERREUR(19) 153 : GOTO 1999 154 : ENDIF 155 : endif 156 : * 157 : IRET = 1 157 : CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET) 158 : IF (IRET.EQ.0) GOTO 1999 159 : * 160 : NEF = NEFMOD 161 : ICOQ = 0 161 : CALL PLACE2(INUCOQ,LNUCOQ,ICOQ,NEF) 162 : IMAS = 0 162 : CALL PLACE2(INUMA,LINUM,IMAS,NEF) 163 : IF (IMAS.EQ.0.and . ituy.eq.0) THEN 164 : WRITE(IOIMP,*) '### ERREUR DANS ADVE : ', 165 : & 'SEULS LES ELEMENTS FINIS MASSIFS SONT ENVISAGES' 165 : CALL ERREUR(19) 166 : GOTO 1999 167 : ENDIF 168 : 169 : C- Recuperation d'informations sur l'element fini 169 : CALL TSHAPE(NEF,'GAUSS',IPINTE) 170 : IF (IERR.NE.0) GOTO 1999 171 : MINTE = IPINTE 172 : SEGACT,MINTE 173 : 174 : C- Recuperation des noms des composantes du champ vectoriel (obligatoires) 175 : 176 : if( ituy.eq.0) then 177 : nbrobl = IDIM 178 : nbrfac = 0 179 : SEGINI,nomid 180 : IF (IDIM.EQ.1) THEN 181 : lesobl(1) = 'UX ' 182 : ELSE IF (IDIM.EQ.2) THEN 183 : lesobl(1) = 'UX ' 184 : lesobl(2) = 'UY ' 185 : c* ELSE IF (IDIM.EQ.3) THEN 186 : ELSE 187 : lesobl(1) = 'UX ' 188 : lesobl(2) = 'UY ' 189 : lesobl(3) = 'UZ ' 190 : ENDIF 191 : else 192 : nbrobl=4 193 : nbrfac = 0 194 : SEGINI,nomid 195 : lesobl(1)= 'VITE' 196 : lesobl(2)='RHO' 197 : lesobl(3)='C' 198 : lesobl(4)='SECT' 199 : endif 200 : NMATO = lesobl(/2) 201 : NMATF = lesfac(/2) 202 : NMATT = NMATO + NMATF 203 : MOMATE = nomid 204 : 205 : nbtype = 1 206 : SEGINI,notype 207 : type(1) = 'REAL*8' 208 : MOTYPE = notype 209 : 210 : C- Definition du descripteur IDESCR 211 : IDESCR = 0 212 : IF (ICOQ.NE.0 .AND. IF1.NE.0) THEN 213 : PEAU = ' ' 214 : IF (MATMOD(/1) .NE. 0) PEAU = MATMOD(1) 214 : CALL TCONV2(ICOQ,PEAU,NBNOE1,IDESCR) 215 : ELSE 215 : CALL TCOND2(ICOQ,NBNOE1,IDESCR) 216 : ENDIF 217 : descr = IDESCR 218 : SEGACT,descr 219 : NLIGRD = LISDUA(/2) 220 : NLIGRP = LISINC(/2) 221 : SEGDES,descr 222 : LRE = NLIGRP 223 : C- Partionnement si necessaire de la matrice de conductivite 224 : C- determinant ainsi le nombre d'objets elementaires de MRIGID 225 : LTRK = oooval(1,4) 226 : IF (LTRK.EQ.0) LTRK = oooval(1,1) 227 : * Ajout a la taille en mots de la matrice des infos du segment 228 : LSEG = LRE*LRE*NBELE1 + 16 229 : NBLPRT = (LSEG-1)/LTRK + 1 230 : NBLMAX = (NBELE1-1)/NBLPRT + 1 231 : NBLPRT = (NBELE1-1)/NBLMAX + 1 232 : * write(ioimp,*) ' tadve1 : nblprt nblmax = ',nblprt,nblmax,nbele1 233 : 234 : C- Ajout de la matrice d'ADVECTION a la matrice globale 235 : NRIGE0 = IRIGEL(/2) 236 : NRIGEL = NRIGE0 + NBLPRT 237 : SEGADJ,MRIGID 238 : 239 : descr = IDESCR 240 : meleme = IPT1 241 : nbnn = NBNOE1 242 : nbelem = NBELE1 243 : nbsous = 0 244 : nbref = 0 245 : 246 : C==== 247 : C Boucle sur les PARTITIONS elementaires de la matrice 248 : C==== 249 : DO 200 irige = 1, NBLPRT 250 : 251 : IF (NBLPRT.GT.1) THEN 252 : C-- Partitionnement du maillage support de la matrice elementaire 253 : SEGACT,IPT1 254 : ielem = (irige-1)*NBLMAX 255 : nbelem = MIN(NBLMAX,NBELE1-ielem) 256 : * write(ioimp,*) 'tadve1 : creation segment ',nbnn,nbelem 257 : SEGINI,meleme 258 : itypel = IPT1.itypel 259 : DO ielt = 1, nbelem 260 : jelt = ielt + ielem 261 : DO inoe = 1, nbnn 262 : num(inoe,ielt) = IPT1.NUM(inoe,jelt) 263 : ENDDO 264 : icolor(ielt) = IPT1.ICOLOR(jelt) 265 : ENDDO 266 : C-- Recopie du descripteur 267 : des1 = IDESCR 268 : SEGINI,descr=des1 269 : SEGDES,descr 270 : ENDIF 271 : ipmail = meleme 272 : ipdesc = descr 273 : 274 : C-- Initialisation de la matrice de rigidite elementaire (xmatri) 275 : NELRIG = nbelem 276 : SEGINI,xmatri 277 : ipmatr = xmatri 278 : 279 : C-- Recuperation des valeurs des caracteristiques necessaires 280 : IVAMAT = 0 280 : CALL KOMCHA(IPCHEL,ipmail,CONM,MOMATE,MOTYPE,1,INFOS,3,IVAMAT) 281 : IF (IERR.NE.0) GOTO 2999 282 : IF (ISUPCH.EQ.1) THEN 282 : CALL VALCHE(IVAMAT,NMATT,IPINTE,0) 283 : IF (IERR.NE.0) THEN 284 : ISUPCH = 0 285 : GOTO 2999 286 : ENDIF 287 : ENDIF 288 : 289 : C-- Calcul de la matrice elementaire pour la zone irige (ipmail) et 290 : C-- Remplissage de la matrice globale (ipmatr) 291 : C Note : actuellement uniquement les elements massifs 292 : if(imas.ne.0) then 292 : CALL TADVE8(NEF,ipmail,IPINTE,MATE,IVAMAT,NMATT,ISYMM, 293 : & ipmatr,LRE) 294 : elseif(ituy.ne.0) then 294 : call adtuy(nef,ipmail,ipinte,mate,ivamat,nmatt, ipmatr, 295 : & lre) 296 : else 296 : call erreur(19) 297 : endif 298 : C-- Un peu de menage dans les segments 299 : 2999 CONTINUE 300 : IF (ISUPCH.EQ.1 .OR. NBLPRT.NE.1) THEN 300 : CALL DTMVAL(IVAMAT,3) 301 : ELSE 301 : CALL DTMVAL(IVAMAT,1) 302 : ENDIF 303 : C-- Sortie prematuree en cas d'erreur 304 : IF (IERR.NE.0) GOTO 1999 305 : 306 : xmatri = ipmatr 307 : SEGDES,xmatri 308 : IF (NBLPRT.GT.1) THEN 309 : meleme = ipmail 310 : SEGDES,meleme 311 : ENDIF 312 : C-- Stockage de la matrice 313 : jrige = NRIGE0 + irige 314 : COERIG(jrige) = 1. 315 : IRIGEL(1,jrige) = ipmail 316 : IRIGEL(2,jrige) = 0 317 : IRIGEL(3,jrige) = ipdesc 318 : IRIGEL(4,jrige) = ipmatr 319 : IRIGEL(5,jrige) = NIFOUR 320 : IRIGEL(6,jrige) = 0 321 : IRIGEL(7,jrige) = 0 322 : IF (ISYMM.NE.1) IRIGEL(7,jrige) = 2 323 : IRIGEL(8,jrige) = 0 324 : 325 : 200 CONTINUE 326 : C==== 327 : C FIN DE LA BOUCLE SUR LES PARTITIONS 328 : C==== 329 : 330 : C- Un peu de menage dans les segments 331 : 1999 CONTINUE 332 : SEGDES,IPT1 333 : SEGDES,IMODEL 334 : IF (IPINTE.NE.0) THEN 335 : MINTE = IPINTE 336 : SEGDES,MINTE 337 : ENDIF 338 : IF (MOMATE.NE.0) THEN 339 : nomid = MOMATE 340 : SEGSUP,nomid 341 : ENDIF 342 : IF (MOTYPE.NE.0) THEN 343 : notype = MOTYPE 344 : SEGSUP,notype 345 : ENDIF 346 : IF (IERR.NE.0) GOTO 999 347 : 348 : 10 CONTINUE 349 : C--- 350 : C FIN DE LA BOUCLE SUR LES MODELES ELEMENTAIRES 351 : C--- 352 : 353 : IPRIGI = MRIGID 354 : SEGDES,MRIGID 355 : 356 : 999 CONTINUE 357 : SEGDES,MMODEL 358 : 359 : RETURN 360 : END 361 : 362 : 363 :
© Cast3M 2003 - All rights reserved.
Disclaimer