1 : C ROT3R SOURCE CHAT 11/03/16 21:31:24 6902 2 : SUBROUTINE ROT3R(NEF,IMAIL,IPMODE,IPCHEM,IPRIGI) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : ************************************************************************ 6 : * 7 : * R O T 3 R 8 : * --------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * CALCUL DE LA MATRICE DE RESISTANCE POUR L'ELEMENT ROT3 13 : * 14 : * MODULES UTILISES: 15 : * ----------------- 16 : * 17 : -INC CCOPTIO 18 : -INC CCREEL 19 : *- 20 : -INC SMCOORD 21 : -INC SMINTE 22 : -INC CCHAMP 23 : -INC SMMODEL 24 : -INC SMRIGID 25 : -INC SMELEME 26 : -INC SMCHAML 27 : * 28 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 29 : * ----------- 30 : * 31 : * NEF (E) NUMERO DE L'ELEMENT-FINI DANS NOMTP (VOIR CCHAMP) 32 : * IMAIL (E) NUMERO DU MAILLAGE ELEMENTAIRE CONSIDERE,DANS 33 : * L'OBJET MODELE 34 : * IPMODE (E) POINTEUR SUR UN SEGMENT IMODEL 35 : * IPCHEM (E) POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUE 36 : * +XCOOR (E) VOIR SMCOORD 37 : * +IDIM (E) VOIR CCOPTIO 38 : * +IFOMOD (E) VOIR CCOPTIO 39 : * +XZERO (E) VOIR CCREEL 40 : * IPRIGI (E/S) POINTEUR SUR L'OBJET RESULTAT,DE TYPE RIGIDITE 41 : * 42 : * VARIABLES: 43 : * ---------- 44 : * 45 : * NBNN NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE 46 : * NEF NUMERO DE L'ELEMENT FINI DANS NOMTP (VOIR CCHAMP) 47 : * NBELEM NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE 48 : * NBPGAU NOMBRE DE POINTS DE GAUSS DANS L'ELEMENT-FINI 49 : * NDIM NOMBRE DE LIGNES DE LA MATRICE GRADIENT 50 : * CEL(2*NBNN,2*NBNN) MATRICE DE CONDUCTIVITE ELEMENTAIRE 51 : * XE(3,NBNN) COORDONNEES DE L'ELEMENT DANS LE REPERE GLOBAL 52 : * SHP(6,NBNN) TABLEAU DE TRAVAIL 53 : * GRAD(NDIM,NBNN) MATRICE GRADIENT DES FONCTIONS DE FORME BIDIM. 54 : * VALMAT(NMATR) TABLEAU DE TRAVAIL 55 : * 56 : SEGMENT,MMAT1 57 : REAL*8 VALMAT(NMATR) 58 : REAL*8 XE(3,NBNN),CEL1(NBNN,NBNN),XE1(3,NBNN) 59 : REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN) 60 : ENDSEGMENT 61 : * 62 : SEGMENT NOTYPE 63 : CHARACTER*16 TYPE(NBTYPE) 64 : ENDSEGMENT 65 : * 66 : SEGMENT MPTVAL 67 : INTEGER IPOS(NS) ,NSOF(NS) 68 : INTEGER IVAL(NCOSOU) 69 : CHARACTER*16 TYVAL(NCOSOU) 70 : ENDSEGMENT 71 : * 72 : SEGMENT INFO 73 : INTEGER INFELL(JG) 74 : ENDSEGMENT 75 : * 76 : REAL*8 COSD1(3),COSD2(3),COSD3(3),YK(2,2) 77 : CHARACTER*8 CNM 78 : CHARACTER*(NCONCH) CONM 79 : PARAMETER (NINF=3) 80 : INTEGER INFOS(NINF) 81 : * 82 : * 83 : * 84 : * AUTEUR, DATE DE CREATION: 85 : * ------------------------- 86 : * 87 : * YANN STEPHAN , JANVIER 1997 (COPIE DE TCOQ3C) 88 : * 89 : * LANGAGE: 90 : * -------- 91 : * 92 : * ESOPE + FORTRAN77 93 : * 94 : ************************************************************************ 95 : * 96 : * RECUPERATION DES CARACTERISTIQUES GEOMETRIQUES DU MAILLAGE 97 : * ELEMENTAIRE 98 : * 99 : IMODEL=IPMODE 100 : CONM =CONMOD 101 : IPMAIL=IMAMOD 102 : MELEME=IMAMOD 103 : SEGACT,MELEME 104 : NBNN=NUM(/1) 105 : NBELEM=NUM(/2) 106 : MRIGID=IPRIGI 107 : SEGACT,MRIGID 108 : * 109 : * RECUPERATION DES CARACTERISTIQUES D'INTEGRATION DE L'ELEMENT 110 : * FINI LIE A NOTRE MAILLAGE 111 : * 112 : if(infmod(/1).lt.4) then 112 : CALL ELQUOI(NEF,0,2,IPINF,IMODEL) 113 : IF(IERR.NE.0) THEN 114 : SEGDES IMODEL,MELEME 115 : SEGSUP MRIGID 116 : RETURN 117 : ENDIF 118 : INFO=IPINF 119 : IPINTE=INFELL(11) 120 : else 121 : ipinte=infmod(4) 122 : endif 123 : * 124 : * INFORMATION SUR L'ELEMENT 125 : * 126 : MINTE=IPINTE 127 : SEGACT,MINTE 128 : NBPGAU=POIGAU(/1) 129 : * 130 : xMATRI=IRIGEL(4,IMAIL) 131 : SEGACT,xMATRI*MOD 132 : NLIGRP=NBNN 133 : NLIGRD=NBNN 134 : * 135 : * RECHERCHE LES POINTEURS DES SEGMENTS MELVAL QUI CORRESPONDENT 136 : * AUX COMPOSANTES DE LA CONDUCTIVITE ET L'EPAISSEUR DES ELEMENT 137 : * 138 : NFOR=FORMOD(/2) 139 : NMAT=MATMOD(/2) 139 : CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CNM,INM,INT) 140 : IF (IERR.NE.0) THEN 141 : SEGDES,MELEME 142 : SEGDES,MINTE 143 : SEGSUP,MRIGID,xMATRI 144 : RETURN 145 : ENDIF 146 : * 147 : * REMLIR LE TABLEAU INFOS (INFORMATIONS SUR ELEMENT) 148 : INFOS(1)=0 149 : INFOS(2)=0 150 : INFOS(3)=NIFOUR 151 : * 152 : NBROBL=0 153 : NBRFAC=0 154 : IF(CNM.EQ.'ISOTROPE')THEN 155 : NBROBL=2 156 : SEGINI NOMID 157 : MOMATR=NOMID 158 : LESOBL(1)='ETA ' 159 : LESOBL(2)='EPAI' 160 : NMATR=2 161 : NMATF=0 162 : ELSE IF(CNM.EQ.'ORTHOTRO') THEN 163 : NBROBL=5 164 : SEGINI NOMID 165 : MOMATR=NOMID 166 : LESOBL(1)='ETA1' 167 : LESOBL(2)='ETA2' 168 : LESOBL(3)='EPAI' 169 : LESOBL(4)='V1X ' 170 : LESOBL(5)='V1Y ' 171 : NMATR=5 172 : NMATF=0 173 : ELSE 173 : CALL ERREUR(251) 174 : SEGSUP,xMATRI,MRIGID 175 : SEGDES, MELEME 176 : SEGDES, MINTE 177 : RETURN 178 : ENDIF 179 : SEGDES NOMID 180 : * 181 : NBTYPE=1 182 : SEGINI NOTYPE 183 : MOTYPE=NOTYPE 184 : TYPE(1)='REAL*8' 185 : * 185 : CALL KOMCHA(IPCHEM,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) 186 : SEGSUP NOTYPE 187 : IF(IERR.NE.0)THEN 188 : SEGSUP,xMATRI,MRIGID 189 : SEGDES,MELEME 190 : SEGDES,MINTE 191 : RETURN 192 : ENDIF 193 : * 194 : MPTVAL=IVAMAT 195 : IF(CNM.EQ.'ISOTROPE')THEN 196 : IPMELV=IVAL(2) 197 : ELSE IF(CNM.EQ.'ORTHOTRO') THEN 198 : IPMELV=IVAL(3) 199 : ENDIF 199 : CALL QUELCH(IPMELV,ICONS) 200 : IF(ICONS.NE.0)THEN 200 : CALL ERREUR(566) 201 : SEGSUP,MRIGID,xMATRI 202 : SEGDES,MELEME 203 : SEGDES,MINTE 203 : CALL DTMVAL(IVAMAT,1) 204 : RETURN 205 : ENDIF 206 : * 207 : * 208 : NDIM=IDIM-1 209 : SEGINI,MMAT1 210 : * 211 : * BOUCLE SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IMAIL 212 : * 213 : DO 10 IEL=1,NBELEM 214 : * 215 : * MISE A ZERO DES TABLEAUX CEL1 ET XE1 216 : * 216 : CALL ZERO(CEL1,NBNN,NBNN) 216 : CALL ZERO (XE1,3,NBNN) 217 : * 218 : * ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IEL, 219 : * DANS LE REPERE GLOBAL 220 : * 220 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) 221 : * 222 : * CALCUL DES COORDONNEES DES NOEUDS DANS LE REPERE LOCAL DE L' 223 : * ELEMENT COQUE 224 : * 225 : DO 60 I=1,3 226 : COSD1(I)=XE(I,2)-XE(I,1) 227 : COSD2(I)=XE(I,3)-XE(I,1) 228 : 60 CONTINUE 229 : * 230 : COSD3(1)=COSD1(2)*COSD2(3)-COSD1(3)*COSD2(2) 231 : COSD3(2)=COSD1(3)*COSD2(1)-COSD1(1)*COSD2(3) 232 : COSD3(3)=COSD1(1)*COSD2(2)-COSD1(2)*COSD2(1) 233 : * 234 : COSD1L=SQRT(COSD1(1)*COSD1(1)+COSD1(2)*COSD1(2)+ 235 : . COSD1(3)*COSD1(3)) 236 : COSD3L=SQRT(COSD3(1)*COSD3(1)+COSD3(2)*COSD3(2)+ 237 : . COSD3(3)*COSD3(3)) 238 : * 239 : DO 70 I=1,3 240 : COSD1(I)=COSD1(I)/COSD1L 241 : COSD3(I)=COSD3(I)/COSD3L 242 : 70 CONTINUE 243 : * 244 : COSD2(1)=COSD3(2)*COSD1(3)-COSD3(3)*COSD1(2) 245 : COSD2(2)=COSD3(3)*COSD1(1)-COSD3(1)*COSD1(3) 246 : COSD2(3)=COSD3(1)*COSD1(2)-COSD3(2)*COSD1(1) 247 : * 248 : DO 80 NOE=1,NBNN 249 : DO 80 I=1,3 250 : XE1(1,NOE)=XE1(1,NOE)+XE(I,NOE)*COSD1(I) 251 : XE1(2,NOE)=XE1(2,NOE)+XE(I,NOE)*COSD2(I) 252 : 80 CONTINUE 253 : * 254 : * 255 : * BOUCLE SUR LES POINTS DE GAUSS 256 : * 257 : IFOIS=0 258 : IFOI2=0 259 : DO 20 IGAU=1,NBPGAU 260 : * 261 : * CALCUL DE LA MATRCIE GRADIENT DES FONCTIONS DE FORME ET 262 : * DU JACOBIEN(DANS LE PLAN), EN UN POINT DE GAUSS 263 : * 264 : NFIN=NDIM+1 265 : DO 90 NP=1,NBNN 266 : DO 90 I=1,NFIN 267 : SHP(I,NP)=SHPTOT(I,NP,IGAU) 268 : 90 CONTINUE 269 : * 270 : * DERIVES DES FONCTIONS DE FORME DANS LA GEOMETRIE REELLE 271 : * ET LE JACOBIEN 271 : CALL JACOBI(XE1,SHP,NDIM,NBNN,DJAC) 272 : * 273 : DO 100 NP=1,NBNN 274 : DO 100 I= 1,NDIM 275 : GRAD(I,NP)=SHP(I+1,NP) 276 : 100 CONTINUE 277 : IF(DJAC.LT.XZERO)IFOIS=IFOIS+1 278 : IF(ABS(DJAC).LT.XPETIT)IFOI2=IFOI2 +1 279 : * 280 : * ON MULTIPLIE LE JACOBIEN PAR LE POIDS D'INTEGRATION,POUR LE 281 : * POINT DE GAUSS CONSIDERE 282 : * 283 : DJAC=ABS(DJAC)*POIGAU(IGAU) 284 : * 285 : * ON CHERCHE LES VALEURS DE COMPOSANTES DE LA RESISTIVITE 286 : * ET L'EPAISSEUR DE LA COQUE 287 : * 288 : MPTVAL=IVAMAT 289 : DO 30 IM=1,NMATR 290 : IF(IVAL(IM).NE.0)THEN 291 : MELVAL=IVAL(IM) 292 : IBMN=MIN(IEL,VELCHE(/2)) 293 : IGMN=MIN(IGAU,VELCHE(/1)) 294 : VALMAT(IM)=VELCHE(IGMN,IBMN) 295 : ELSE 296 : VALMAT(IM)=0 297 : ENDIF 298 : 30 CONTINUE 299 : * 300 : * MATERIAU ISOTROPE 301 : * 302 : IF(CNM.NE.'ORTHOTRO')THEN 303 : * 304 : EP=VALMAT(2) 305 : IF(EP.LE.XPETIT)THEN 306 : * L'ELEMENT (IEL) AU POINT DE GAUSS (IGAU)DE TYPE (NOMTP(NEF)) A 307 : * UNE EPAISSEUR NULLE 308 : INTERR(1)=IEL 309 : INTERR(2)=IGAU 310 : MOTERR(1:4)=NOMTP(NEF) 310 : CALL ERREUR(355) 311 : SEGSUP,MRIGID,xMATRI 312 : GO TO 999 313 : ENDIF 314 : XK=VALMAT(1)*DJAC/EP 315 : * 316 : * ON AJOUTE LE PRODUIT K*DJAC*TRANSPOSEE(GRAD)*GRAD 317 : * POUR LE POINT DE GAUSS CONSIDERE,A LA MATRICE CEL1 318 : * 318 : CALL NTNST (GRAD,XK,NBNN,NDIM,CEL1) 319 : * 320 : * 321 : ELSE 322 : * 323 : * CAS ORTHOTROPE 324 : * 325 : EP=VALMAT(3) 326 : IF(EP.LE.XPETIT)THEN 327 : * L'ELEMENT (IEL) AU POINT DE GAUSS (IGAU)DE TYPE (NOMTP(NEF)) A 328 : * UNE EPAISSEUR NULLE 329 : INTERR(1)=IEL 330 : INTERR(2)=IGAU 331 : MOTERR(1:4)=NOMTP(NEF) 331 : CALL ERREUR(355) 332 : SEGSUP,MRIGID,xMATRI 333 : GO TO 999 334 : ENDIF 335 : XK1=VALMAT(1)/EP 336 : XK2=VALMAT(2)/EP 337 : * 338 : COSA=VALMAT(4) 339 : SINA=-VALMAT(5) 340 : * CALCUL DE LA MATRICE DES COEFFICIENTS DE RESISTIVITE DANS LE 341 : * PLAN,PAR RAPPORT AU REPERE LOCAL DE L'ELEMENT 342 : * 343 : COS2=COSA*COSA 344 : SIN2=SINA*SINA 345 : SINCOS=SINA*COSA 346 : YK(1,1)=COS2*XK1+SIN2*XK2 347 : YK(1,2)=SINCOS*(XK1-XK2) 348 : YK(2,1)=YK(1,2) 349 : YK(2,2)=SIN2*XK1+COS2*XK2 350 : 351 : * 352 : * ON AJOUTE LE PRODUIT DJAC*TRANSPOSEE(GRAD)*YK*GRAD 353 : * POUR LE POINT DE GAUSS CONSIDERE,A LA MATRICE CEL1 354 : * 354 : CALL BDBST (GRAD,DJAC,YK,NBNN,NDIM,CEL1) 355 : * 356 : ENDIF 357 : * 358 : 20 CONTINUE 359 : * 360 : * 361 : IF(IFOIS.NE.0.AND.IFOIS.NE.NBPGAU)THEN 362 : * 363 : * LE JACOBIEN EST NEGATIF ,MAILLAGE INCORRECT 364 : INTERR(1)=IEL 364 : CALL ERREUR(195) 365 : SEGSUP,xMATRI,MRIGID 366 : GO TO 999 367 : ELSEIF(IFOI2.EQ.NBPGAU)THEN 368 : * 369 : * CAS OU LE JACOBIEN EST TRES PETIT 370 : * 371 : INTERR(1)=IEL 371 : CALL ERREUR (259) 372 : SEGSUP,xMATRI,MRIGID 373 : GO TO 999 374 : ENDIF 375 : * 376 : * SEGINI,XMATRI 377 : * IMATTT(IEL)=XMATRI 378 : * 379 : * REMPLISSAGE DE XMATRI 380 : * 380 : CALL REMPMT(CEL1,NBNN,RE(1,1,iel)) 381 : * SEGDES,XMATRI 382 : 10 CONTINUE 383 : * END DO 384 : * 385 : * DESACTIVATION DES SEGMENTS 386 : * 387 : SEGDES,xMATRI,MRIGID 388 : 999 CONTINUE 389 : SEGSUP,MMAT1 390 : 99 CONTINUE 391 : SEGDES,MELEME 392 : SEGDES,MINTE 393 : * SEGDES,INFO 394 : * 395 : MPTVAL=IVAMAT 396 : DO 50 I=1,NMATR 397 : MELVAL=IVAL(I) 398 : SEGDES,MELVAL 399 : 50 CONTINUE 400 : SEGSUP MPTVAL 401 : NOMID=MOMATR 402 : SEGSUP NOMID 403 : * 404 : RETURN 405 : END 406 : 407 : 408 :
© Cast3M 2003 - All rights reserved.
Disclaimer