1 : C SORE2 SOURCE CHAT 11/03/16 21:31:40 6902 2 : 3 : SUBROUTINE SORE2(NEF,IMAIL,IPMODE,IPCHE1,IPCHEM,IPCHE4,IPRIGI) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8(A-H,O-Z) 6 : ************************************************************************ 7 : * 8 : * SORE2 9 : * ------ 10 : * CREATION DE LA MATRICE DE CONDUCTIVITE N DIV(GRAD T) 11 : * ( EFFET SORET) 12 : * 13 : * FONCTION: 14 : * --------- 15 : * TRAITEMENT DU CAS DES ELEMENTS-FINIS MASSIFS A INTEGRATION 16 : * NUMERIQUE,POUR UN MAILLAGE ELEMENTAIRE 17 : * 18 : 19 : * 20 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 21 : * ----------- 22 : * 23 : * NEF (E) NUMERO DE L'ELEMENT-FINI DANS NOMTP (VOIR CCHAMP) 24 : * IMAIL (E) NUMERO DU MAILLAGE ELEMENTAIRE CONSIDERE,DANS 25 : * L'OBJET MODELE 26 : * IPMODE (E) POINTEUR SUR UN SEGMENT IMODEL 27 : * IPCHEM (E) POINTEUR SUR UN CHAMELEM (GRAD T aux PTS de GAUSS) 28 : * IPCHE1 (E) POINTEUR SUR UN CHAMELEM MATERIAU 29 : * IPCHE4 (E) POINTEUR SUR UN CHAMELEM FACTEUR DE GRAD T 30 : * 31 : * IPRIGI (E/S) POINTEUR SUR L'OBJET RESULTAT,DE TYPE RIGIDITE 32 : * 33 : * VARIABLES: 34 : * ---------- 35 : * 36 : * NBNN NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE 37 : * NEF NUMERO DE L'ELEMENT FINI DANS NOMTP (VOIR CCHAMP) 38 : * NBELEM NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE 39 : * NBPGAU NOMBRE DE POINTS DE GAUSS DANS L'ELEMENT-FINI 40 : * NDIM NOMBRE DE LIGNES DE LA MATRICE GRADIENT 41 : * CEL(NBNN,NBNN) MATRICE DE CONDUCTIVITE ELEMENTAIRE NON SYMETRIQUE 42 : * XE(3,NBNN) COORDONNEES DE L'ELEMENT DANS LE REPERE GLOBAL 43 : * SHP(6,NBNN) TABLEAU DE TRAVAIL 44 : * GRAD(NDIM,NBNN) MATRICE GRADIENT DES FONCTIONS DE FORME 45 : * 46 : * 47 : * 48 : * AUTEUR, DATE DE CREATION: 49 : * ------------------------- 50 : * 51 : * J.M.BAZE AVRIL 97 52 : * 53 : * LANGAGE: 54 : * -------- 55 : * 56 : * ESOPE + FORTRAN77 57 : * 58 : ************************************************************************ * 59 : * MODULES UTILISES: 60 : * ----------------- 61 : * 62 : -INC CCOPTIO 63 : -INC CCREEL 64 : *- 65 : -INC SMCOORD 66 : -INC SMINTE 67 : C-INC CCHAMP 68 : -INC SMMODEL 69 : -INC SMRIGID 70 : -INC SMELEME 71 : -INC SMCHAML 72 : * 73 : SEGMENT MPTVAL 74 : INTEGER IPOS(NS) ,NSOF(NS) 75 : INTEGER IVAL(NCOSOU) 76 : CHARACTER*16 TYVAL(NCOSOU) 77 : ENDSEGMENT 78 : * 79 : SEGMENT ,MAXE 80 : REAL*8 TXR(IDIM,IDIM),XLOC(IDIM,IDIM),XGLOB(IDIM,IDIM) 81 : ENDSEGMENT 82 : * 83 : SEGMENT,MMAT1 84 : REAL*8 CEL(NBNN,NBNN),XE(3,NBNN) 85 : REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN) 86 : REAL*8 CMAT(NDIM,NDIM),CMAT1(IDIM,IDIM) 87 : ENDSEGMENT 88 : * 89 : SEGMENT NOTYPE 90 : CHARACTER*16 TYPE(NBTYPE) 91 : ENDSEGMENT 92 : * 93 : SEGMENT,MVELCH 94 : REAL*8 GDT(IDIM),VALMAT(NV1), GDTL(IDIM) 95 : ENDSEGMENT 96 : * 97 : CHARACTER*8 CNM 98 : CHARACTER*(NCONCH) CONM 99 : PARAMETER(NINF=3) 100 : INTEGER INFOS(NINF) 101 : LOGICAL lsupma 102 : 103 : * 104 : * RECUPERATION DES CARACTERISTIQUES GEOMETRIQUES DU MAILLAGE 105 : * ELEMENTAIRE 106 : * 107 : IMODEL=IPMODE 108 : SEGACT,IMODEL 109 : IPMAIL=IMAMOD 110 : MELEME=IMAMOD 111 : SEGACT,MELEME 112 : NBNN=NUM(/1) 113 : NBELEM=NUM(/2) 114 : * 115 : * RECUPERATION DES CARACTERISTIQUES D'INTEGRATION DE L'ELEMENT 116 : * FINI LIE A NOTRE MAILLAGE 117 : * 117 : CALL TSHAPE(NEF,'GAUSS',IPINTE) 118 : IF (IERR.NE.0) THEN 119 : SEGDES,IMODEL,MELEME 120 : RETURN 121 : ENDIF 122 : MINTE=IPINTE 123 : SEGACT,MINTE 124 : NBPGAU=POIGAU(/1) 125 : 126 : * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE 127 : * DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX 128 : * 129 : NLG=NUMGEO(NEF) 129 : CALL RESHPT(1,NBNN,NLG,NEF,0,IPT1,IRT1) 130 : MINTE1=IPT1 131 : SEGACT MINTE1 132 : 133 : * 134 : MRIGID=IPRIGI 135 : SEGACT,MRIGID 136 : xMATRI=IRIGEL(4,IMAIL) 137 : SEGACT,xMATRI*MOD 138 : 139 : NLIGRP=NBNN 140 : NLIGRD=NBNN 141 : 142 : *-------------------------- 143 : * RECHERCHE POINTEUR DU SEGMENTS MELVAL CONTENANT 144 : * LA DIFFUSIVITE 145 : 146 : NFOR=FORMOD(/2) 147 : NMAT=MATMOD(/2) 147 : CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CNM,INM,INT) 148 : IF (IERR.NE.0) THEN 149 : SEGDES,IMODEL,MELEME 150 : SEGDES,MINTE,MINTE1 151 : SEGSUP,MRIGID,xMATRI 152 : RETURN 153 : ENDIF 154 : * 155 : * REMLIR LE TABLEAU INFOS (INFORMATIONS SUR ELEMENT) 156 : INFOS(1)=0 157 : INFOS(1)=0 158 : INFOS(2)=0 159 : INFOS(3)=NIFOUR 160 : * 161 : MFR=1 162 : if(lnomid(6).ne.0) then 163 : nomid=lnomid(6) 164 : segact nomid 165 : momatr=nomid 166 : nmatr=lesobl(/2) 167 : nmatf=lesfac(/2) 168 : lsupma=.false. 169 : else 170 : lsupma=.true. 170 : CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF) 171 : endif 172 : NMATT=NMATR 173 : NV1=NMATT 174 : * 175 : NBTYPE=1 176 : SEGINI NOTYPE 177 : MOTYPE=NOTYPE 178 : TYPE(1)='REAL*8' 179 : * 179 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) 180 : SEGSUP NOTYPE 181 : IF(IERR.NE.0)THEN 182 : SEGSUP,xMATRI,MRIGID 183 : SEGDES,MELEME 184 : SEGDES,IMODEL 185 : SEGDES,MINTE,MINTE1 186 : RETURN 187 : ENDIF 188 : *---------------------------- 189 : 190 : * recuperation des MELVAL composantes du gradient aux pts de Gauss 191 : * et de leurs multiplicateurs 192 : MCHEL1=IPCHEM 193 : MCHEL2=IPCHE4 194 : SEGACT,MCHEL1,MCHEL2 195 : 196 : MCHAM1 = MCHEL1.ICHAML(1) 197 : MCHAM2 = MCHEL2.ICHAML(1) 198 : SEGACT,MCHAM1,MCHAM2 199 : SEGDES,MCHEL1,MCHEL2 200 : * 201 : MELVA1=MCHAM1.IELVAL(1) 202 : MELVA2=MCHAM1.IELVAL(2) 203 : SEGACT,MELVA1,MELVA2 204 : IF(IDIM.EQ.3) THEN 205 : MELVA3=MCHAM1.IELVAL(3) 206 : SEGACT,MELVA3 207 : ENDIF 208 : MELVA4 =MCHAM2.IELVAL(1) 209 : SEGACT,MELVA4 210 : * 211 : NDIM=IDIM 212 : SEGINI,MMAT1,MVELCH,MAXE 213 : * 214 : * BOUCLE SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IMAIL 215 : * 216 : DO 10 IEL=1,NBELEM 217 : * 218 : * MISE A ZERO DU TABLEAU CEL 219 : * 219 : CALL ZERO(CEL,NBNN,NBNN) 220 : * ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IEL, 221 : * DANS LE REPERE GLOBAL 222 : * 222 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) 223 : * 224 : * CALCUL DES AXES LOCAUX DANS LE CAS ORTHO 225 : * 226 : IF(INM.EQ.2)THEN 227 : NBSH=MINTE1.SHPTOT(/2) 227 : CALL RLOCAL(XE,MINTE1.SHPTOT,NBSH,NBNN,TXR) 228 : if (nbsh.eq.-1) then 228 : call erreur(525) 229 : return 230 : endif 231 : ENDIF 232 : 233 : * BOUCLE SUR LES POINTS DE GAUSS 234 : * 235 : IFOIS=0 236 : IFOI2=0 237 : 238 : DO 20 IGAU=1,NBPGAU 239 : * 240 : * CALCUL DE LA MATRICE GRADIENT DES FONCTIONS DE FORME ET 241 : * DU JACOBIEN,EN UN POINT DE GAUSS 242 : * 242 : CALL TCOND5(IGAU,NBNN,NDIM,XE,SHPTOT,SHP,GRAD,DJAC) 243 : * SI IFOMOD = 0 axi DJAC CONTITNT DEJA LE MULTIPLICATEUR 2*XPI*R 244 : 245 : IF (IERR.NE.0) THEN 246 : SEGSUP,xMATRI,MRIGID 247 : GOTO 99 248 : ENDIF 249 : IF (DJAC.LT.XZERO) THEN 250 : IFOIS=IFOIS+1 251 : ENDIF 252 : IF (ABS(DJAC).LT.XPETIT) THEN 253 : IFOI2=IFOI2+1 254 : ENDIF 255 : * 256 : * ON MULTIPLIE LE JACOBIEN PAR LE POIDS D'INTEGRATION, 257 : * POUR LE POINT DE GAUSS CONSIDERE 258 : * 259 : DJAC=ABS(DJAC)*POIGAU(IGAU) 260 : 261 : * VALEURS DES COMPOSANTES DES GRADIENTS 262 : 263 : DO 29 IM=1,IDIM 264 : MELVAL=MCHAM1.IELVAL(IM) 265 : IBMN=MIN(IEL,VELCHE(/2)) 266 : IGMN=MIN(IGAU,VELCHE(/1)) 267 : GDT(IM)=VELCHE(IGMN,IBMN) 268 : 29 CONTINUE 269 : * FACTEUR DE GRAD T 270 : IBMN=MIN(IEL,MELVA4.VELCHE(/2)) 271 : IGMN=MIN(IGAU,MELVA4.VELCHE(/1)) 272 : RMUL = MELVA4.VELCHE(IGMN,IBMN) 273 : * 274 : * DIFFUSIVITE DANS LE REPERE LOCAL 275 : * 276 : MPTVAL=IVAMAT 277 : DO 30 IM=1,NMATT 278 : IF(IVAL(IM).NE.0)THEN 279 : MELVAL=IVAL(IM) 280 : IBMN=MIN(IEL,VELCHE(/2)) 281 : IGMN=MIN(IGAU,VELCHE(/1)) 282 : VALMAT(IM)=VELCHE(IGMN,IBMN) 283 : ELSE 284 : VALMAT(IM)=0.D0 285 : ENDIF 286 : 30 CONTINUE 287 : 288 : * 289 : IF (INM.EQ.1) THEN 290 : *------------------------ MATERIAU ISOTROPE ---------------------------- 291 : * 292 : * INTEGRATION DES TERMES N VI B 293 : * 294 : RK = VALMAT(1)*DJAC*RMUL 295 : DO 700 K=1,IDIM 296 : XK = GDT(K)*RK 297 : DO 300 I=1,NBNN 298 : DO 400 J=1,NBNN 299 : CEL(J,I) = CEL(J,I) + SHP(1,I)*GRAD(K,J)*XK 300 : 400 CONTINUE 301 : 300 CONTINUE 302 : 700 CONTINUE 303 : * 304 : ELSE 305 : *------------------- MATERIAU ORTHOTROPE ----------------- 305 : CALL ZERO(CMAT,NDIM,NDIM) 305 : CALL ZERO(CMAT1,IDIM,IDIM) 305 : CALL ZERO(XGLOB,IDIM,IDIM) 306 : IF(IDIM.EQ.2) THEN 307 : *----------BIDIM 308 : 309 : * MATERIAU ORTHOTROPE 310 : 311 : XLOC(1,1)=VALMAT(3) 312 : XLOC(2,1)=VALMAT(4) 313 : XLOC(1,2)=-VALMAT(4) 314 : XLOC(2,2)=VALMAT(3) 315 : 316 : * CALCUL DES COS.DIRECTEURS DES AXES ORTH. /REPERE GLOBAL 317 : * XGLOB=TXR*XLOC 318 : * 319 : DO 40 K=1,IDIM 320 : DO 409 J=1,IDIM 321 : DO 4099 I=1,IDIM 322 : XGLOB(K,J)=TXR(J,I)*XLOC(I,K)+XGLOB(K,J) 323 : 4099 CONTINUE 324 : 409 CONTINUE 325 : 40 CONTINUE 326 : * 327 : DO 51 I = 1,IDIM 328 : CMAT1(I,I) = VALMAT(I) 329 : 51 CONTINUE 330 : * 331 : * RETOUR DANS LE REPERE GLOBAL 331 : CALL PRODT(CMAT,CMAT1,XGLOB,IDIM,IDIM) 332 : DO 41 I= 1, IDIM 333 : GDTL(I) = 0.D0 334 : DO 411 J= 1, IDIM 335 : GDTL(I) = GDTL(I) + CMAT(I,J)*GDT(J) 336 : 411 CONTINUE 337 : 41 CONTINUE 338 : * 339 : ELSE 340 : *----------TRIDIM MATERIAU ORTHOTROPE ------------------- 341 : 342 : XLOC(1,1)=VALMAT(4) 343 : XLOC(2,1)=VALMAT(5) 344 : XLOC(3,1)=VALMAT(6) 345 : XLOC(1,2)=VALMAT(7) 346 : XLOC(2,2)=VALMAT(8) 347 : XLOC(3,2)=VALMAT(9) 347 : CALL CROSS2 (XLOC(1,1),XLOC(1,2),XLOC(1,3),IRR) 348 : DO 45 K=1,IDIM 349 : DO 451 J=1,IDIM 350 : DO 452 I=1,IDIM 351 : XGLOB(K,J)=TXR(J,I)*XLOC(I,K)+XGLOB(K,J) 352 : 452 CONTINUE 353 : 451 CONTINUE 354 : 45 CONTINUE 355 : * 356 : DO 52 I = 1,IDIM 357 : CMAT1(I,I) = VALMAT(I) 358 : 52 CONTINUE 359 : * 360 : * RETOUR DANS LE REPERE GLOBAL 360 : CALL PRODT(CMAT,CMAT1,XGLOB,IDIM,IDIM) 361 : 362 : DO 53 I= 1, IDIM 363 : GDTL(I) = 0.D0 364 : DO 531 J= 1, IDIM 365 : GDTL(I) = GDTL(I) + CMAT(I,J)*GDT(J) 366 : 531 CONTINUE 367 : 53 CONTINUE 368 : * 369 : ENDIF 370 : 371 : * INTEGRATION DES TERMES N VI B 372 : * 373 : DO 701 K=1,IDIM 374 : XK = GDTL(K)*DJAC*RMUL 375 : DO 301 I=1,NBNN 376 : DO 401 J=1,NBNN 377 : CEL(J,I) = CEL(J,I) + SHP(1,I)*GRAD(K,J)*XK 378 : 401 CONTINUE 379 : 301 CONTINUE 380 : 701 CONTINUE 381 : ENDIF 382 : * 383 : * FIN DE LA BOUCLE SUR LES POINTS DE GAUSS 384 : * 385 : 20 CONTINUE 386 : * END DO 387 : IF (IFOIS.NE.0.AND.IFOIS.NE.NBPGAU) THEN 388 : * 389 : * LE JACOBIEN EST NEGATIF,MAILLAGE INCORRECT 390 : * 391 : INTERR(1)=IEL 391 : CALL ERREUR(195) 392 : SEGSUP,xMATRI,MRIGID 393 : GO TO 99 394 : ENDIF 395 : IF (IFOI2.EQ.NBPGAU) THEN 396 : * 397 : * CAS OU LE JACOBIEN EST TRES PETIT 398 : * 399 : INTERR(1)=IEL 399 : CALL ERREUR(259) 400 : SEGSUP,xMATRI,MRIGID 401 : GO TO 99 402 : ENDIF 403 : 404 : 1100 FORMAT (4E12.5) 405 : 406 : * SEGINI,XMATRI 407 : 408 : * IMATTT(IEL)=XMATRI 409 : * 410 : * REMPLISSAGE DE XMATRI 411 : * 412 : DO 100 IA=1,NBNN 413 : DO 1001 IB=1,NBNN 414 : RE(IA,IB,iel)=CEL(IA,IB) 415 : 1001 CONTINUE 416 : 100 CONTINUE 417 : 418 : * SEGDES,XMATRI 419 : 10 CONTINUE 420 : * END DO 421 : * 422 : * DESACTIVATION DES SEGMENTS 423 : * 424 : SEGDES,xMATRI,MRIGID 425 : 99 CONTINUE 426 : SEGSUP,MMAT1,MVELCH 427 : 999 CONTINUE 428 : SEGDES,MELEME*NOMOD 429 : SEGDES,IMODEL*NOMOD 430 : SEGDES,MINTE*NOMOD 431 : 432 : * 433 : SEGDES,MELVA4 434 : DO 550 I=1,IDIM 435 : MELVAL=MCHAM1.IELVAL(I) 436 : SEGDES,MELVAL 437 : 550 CONTINUE 438 : * 439 : MPTVAL = IVAMAT 440 : DO 551 I=1,NMATT 441 : MELVAL=IVAL(I) 442 : SEGDES,MELVAL 443 : 551 CONTINUE 444 : SEGSUP,MPTVAL 445 : nomid=momatr 446 : segdes nomid 447 : if(lsupma) segsup nomid 448 : SEGDES,MCHAM1*NOMOD 449 : 450 : RETURN 451 : END 452 : 453 : 454 :
© Cast3M 2003 - All rights reserved.
Disclaimer