1 : C COMARA SOURCE FANDEUR 12/07/18 21:15:00 7435 2 : SUBROUTINE COMARA(IQMOD,IWRK52,IWRK53,iwrk54,wrk2,wr10,ib,igau, 3 : & iretou,necou,iecou,xecou,itruli) 4 : *---------------------------------------------------------- 5 : * quelques manipulations de donnees 6 : * 7 : * MECANIQUE : rangements dans XMAT et VALMAT, compatibilite avec 8 : * la structure de ECOUL 9 : * 10 : * METALLURGIE : creation de nuages pour materiau CEREM 11 : * 12 : c pb kerr0 13 : *---------------------------------------------------------- 14 : IMPLICIT INTEGER(I-N) 15 : IMPLICIT REAL*8(A-H,O-Z) 16 : * 17 : -INC CCOPTIO 18 : -INC SMMODEL 19 : -INC SMLREEL 20 : -INC SMCHAML 21 : -INC DECHE 22 : * 23 : SEGMENT WRK2 24 : REAL*8 TRAC(LTRAC) 25 : ENDSEGMENT 26 : * 27 : ********* SEGMENT WRKTRA 28 : REAL*8 TTRAV(50) 29 : ********* ENDSEGMENT 30 : * 31 : SEGMENT WR10 32 : INTEGER IABLO1(NTABO1) 33 : REAL*8 TABLO2(NTABO2) 34 : ENDSEGMENT 35 : * 36 : SEGMENT WR11 37 : INTEGER IABLO3(NTABO3) 38 : REAL*8 TABLO4(NTABO4) 39 : ENDSEGMENT 40 : * 41 : * Segment NECOU utilisé dans ECOINC 42 : * 43 : SEGMENT NECOU 44 : INTEGER NCOURB,IPLAST,IT,IMAPLA,ISOTRO, 45 : . ITYP,IFOURB,IFLUAG, 46 : . ICINE,ITHER,IFLUPL,ICYCL,IBI, 47 : . JFLUAG,KFLUAG,LFLUAG, 48 : . IRELAX,JNTRIN,MFLUAG,JSOUFL,JGRDEF 49 : ENDSEGMENT 50 : * 51 : * Segment IECOU: sert de fourre-tout pour les initialisations 52 : * d'entiers 53 : * 54 : SEGMENT IECOU 55 : INTEGER NYOG,NYNU,NYALFA,NYSMAX,NYN,NYM,NYKK,NYALF1, 56 : . NYBET1,NYR,NYA,NYRHO,NSIGY,NNKX,NYKX,IND,NSOM,NINV, 57 : . NINCMA,NCOMP,JELEM,LEGAUS,INAT,NCXMAT,LTRAC,MFRBI, 58 : . IELE,NHRM,NBNNBI,NBELMB,ICARA,LW2BI,NDEF,NSTRSS, 59 : . MFR1,NBGMAT,NELMAT,MSOUPA,NUMAT1,LENDO,NBBB,NNVARI, 60 : . KERR1,MELEMB,NYOG1,NYNU1,NYALFT1,NYSMAX1,NYN1,NYM1, 61 : . NYKK1,NYALF2,NYBET2,NYR1,NYA1,NYQ1,NYRHO1,NSIGY1 62 : ENDSEGMENT 63 : * 64 : * Segment XECOU: sert de fourre-tout pour les initialisations 65 : * de réels 66 : * 67 : SEGMENT XECOU 68 : REAL*8 DTOPTI,TSOM,TCAR,DTT,DT,TREFA,TEMP00 69 : ENDSEGMENT 70 : * 71 : LOGICAL XLO,DLIA 72 : * 73 : imodel = iqmod 74 : wrk52 = iwrk52 75 : ****** segact wrk52*mod 76 : wrk53 = iwrk53 77 : ******** segact wrk53*mod 78 : wrk54=iwrk54 79 : 80 : DTOPTI = 1.D6*DT 81 : DTT=DT 82 : TEMP00 = temp0 83 : 84 : C======================== 85 : C = FORMULATION LIAISON = 86 : C======================== 87 : if (itruli.gt.0) then 88 : * 1) suite d un calcul : directement dans coml10 89 : * NEWMOD : nvari = 1 (cf. idvari.eso) 90 : IF (mate.GE.23) RETURN 91 : * Pour les autres types (mate = 1 a 22) : nvari = 5 92 : IF (var0(3).GT.0.D0 .AND. var0(4).GT.0.D0) RETURN 93 : * 2) dimensionnement (voir DYNE72) pour LIAISON 93 : CALL CYNE72(iqmod,iwrk52,itruli) 94 : IF (IERR.NE.0) RETURN 95 : * 96 : * Les segments sont remplis (voir le s-p DEVLIA): 97 : * 97 : CALL cyne20(iqmod,iwrk52,itruli) 98 : RETURN 99 : ENDIF 100 : 101 : C======================== 102 : C = AUTRES FORMULATIONS = 103 : C======================== 104 : * write(6,*) 'comara ', mfrbi, MFR 105 : ncara = xmat(/1) 106 : do ic = 1,ncara 107 : XMAT(ic) = VALMAT(ic) 108 : xmat0(ic) = valma0(ic) 109 : enddo 110 : 111 : IF ((formod(1).NE.'MECANIQUE').AND. 112 : & (formod(1).NE.'POREUX')) GOTO 20 113 : 114 : C======================================== 115 : C = FORMULATIONS 'MECANIQUE' & 'POREUX' = 116 : C======================================== 117 : C 118 : C Poutre 3D 119 : C 120 : IF (MFRbi.EQ.7)THEN 121 : C 122 : IF (IDIM.EQ.3)THEN 123 : C distinction entre poutre bernouilli et poutre timo en ce qui 124 : C concerne le defaut pour les sections reduites de l'effort tranchant 125 : IF(MELE.EQ.84)THEN 126 : SD=XCARB(4) 127 : SREDY=XCARB(5) 128 : SREDZ=XCARB(6) 129 : IF(SREDY.EQ.0) XCARB(5)=SD 130 : IF(SREDZ.EQ.0) XCARB(6)=SD 131 : ENDIF 132 : * rearrangement du tableau xcarB pour qu'on ait le meme ordre 133 : * que l'ancien chamelem 134 : vx = xcarb(7) 135 : vy = xcarb(8) 136 : vz = xcarb(9) 137 : XCARB(7)=XCARB(ICARA-2) 138 : XCARB(8)=XCARB(ICARA-1) 139 : XCARB(9)=XCARB(ICARA) 140 : NTTRAV = icara - 9 - idim 141 : do ic =10,icara - idim 142 : ttrav(ic - 9) = xcarb(ic) 143 : enddo 144 : XCARB(10)=VX 145 : XCARB(11)=VY 146 : XCARB(12)=VZ 147 : do ic = 1,nttrav 148 : xcarb(12+ic) = ttrav(ic) 149 : enddo 150 : * 151 : ELSE IF (IDIM.EQ.2.and.ncarr.ge.3) THEN 152 : C poutre 2D 153 : C distinction entre poutre bernouilli et poutre timo en ce qui 154 : C concerne le defaut pour les sections reduites de l'effort tranchant 155 : SD=XCARB(1) 156 : SREDY=XCARB(3) 157 : IF(SREDY.EQ.0) XCARB(3)=SD 158 : ENDIF 159 : 160 : * 161 : ELSE IF(MFRbi.EQ.13)THEN 162 : NTTRAV = icara - idim - 3 163 : DO 1111 IC=4,icara - idim 164 : TTRAV(IC-3)=XCARB(IC) 165 : 1111 continue 166 : IF(IDIM.EQ.2)THEN 167 : XCARB(4)=XCARB(ICARA-1) 168 : XCARB(5)=XCARB(ICARA) 169 : DO 1112 IC=1,NTTRAV 170 : XCARB(IC+5)=TTRAV(IC) 171 : 1112 continue 172 : ELSE IF(IDIM.EQ.3)THEN 173 : XCARB(4)=XCARB(ICARA-2) 174 : XCARB(5)=XCARB(ICARA-1) 175 : XCARB(6)=XCARB(ICARA) 176 : DO 1113 IC=1,NTTRAV 177 : XCARB(IC+6)=TTRAV(IC) 178 : 1113 continue 179 : ENDIF 180 : ENDIF 181 : * 182 : * cas des poutres en formulation section 183 : * 184 : IF ((MFRbi.EQ.7.OR.MFRbi.EQ.13).AND. 185 : 1 CMATE.EQ.'SECTION') THEN 186 : * 187 : * >>>>>>>>>> cas des materiaux elastiques isotropes 188 : * ou unidirectionnels 189 : * 190 : ELSE IF(MATE.EQ.1.OR.MATE.EQ.4) THEN 191 : IF(INPLAS.EQ. 9.OR.INPLAS.EQ.28.OR.INPLAS.EQ.36.OR. 192 : & INPLAS.EQ.42.OR.INPLAS.EQ.66.OR.INPLAS.EQ.74.OR. 193 : & INPLAS.EQ.65.OR.INPLAS.EQ.106.OR. 194 : & INPLAS.EQ.107.OR.INPLAS.EQ.108.OR. 195 : & INPLAS.EQ.127.OR.INPLAS.EQ.128.OR. 196 : & INPLAS.LT.0) THEN 197 : * 198 : * pour les modeles beton et ubiquitous 199 : * et ceux dont on ne remodifie pas l'ordre 200 : * 201 : ELSE 202 : * 203 : XLO=.TRUE. 204 : IF(MELE.GE.108.AND.MELE.LE.110) XLO=.FALSE. 205 : IF(MFR.EQ.33.AND.MATE.NE.1) XLO=.FALSE. 206 : IF(MFR.EQ.57.OR.MFR.EQ.59) XLO=.FALSE. 207 : * 208 : * on saute des elements n'ayant pas ALPH et RHO 209 : * 210 : IF(XLO) THEN 211 : * pour les autres modeles : 212 : * on a les noms : e,nu,puis le reste des obligatoires 213 : * puis les facultatives qui se terminent par rho et alph 214 : * d'apres un rangement dans idmatr 215 : * dans le remplissage de xmat, on veut e,nu,rho,alph 216 : * puis la suite. d'ou ce qui suit .... 217 : * am 9/11/93 a reprendre !! 218 : * am 28/7/95 le commentaire ci dessus est FAUX si l'on a des 219 : * proprietes facultatives en plus de rho et alph 220 : * car dans ce cas les facultatives COMMENCENT par 221 : * rho et alph. a reprendre !!!!!!!! 222 : * 223 : DO 1106 IC=1,NMATT 224 : IF ((MFRbi.EQ.1.OR.MFRbi.EQ.3.OR.MFRbi.EQ.31 225 : + .OR.MFRbi.EQ.33).AND.IFOUR.EQ.-2) THEN 226 : IF(IC.LE.2.OR.IC.EQ.NMATT) JC=IC 227 : IF(IC.GT.2.AND.IC.LT.NMATT-2) JC=IC+2 228 : IF(IC.EQ.NMATT-2) JC=3 229 : IF(IC.EQ.NMATT-1) JC=4 230 : ELSE 231 : IF(IC.LE.2) JC=IC 232 : IF(IC.GT.2.AND.IC.LT.NMATT-1) JC=IC+2 233 : IF(IC.EQ.NMATT-1) JC=3 234 : IF(IC.EQ.NMATT) JC=4 235 : ENDIF 236 : XMAT(jc) = VALMAT(ic) 237 : xmat0(jc) = valma0(ic) 238 : * le tableau tymat de WRK54 est relatif a XMAT et xma0 239 : tymat(jc) = tyval(ic) 240 : c PRINT *,'XMAT(',JC,')=',XMAT(JC),tymat(jc) 241 : 1106 continue 242 : * 243 : * rearrangement pour certaines lois cas elastique isotrope 244 : * 245 : IF (INPLAS.EQ.7) THEN 246 : * chaboche 1 247 : ELSE IF (INPLAS.EQ.2) THEN 248 : IF (XMAT(6).NE.0.D0) THEN 249 : INPLAS=27 250 : XMAT(5)=XMAT(6) 251 : xmat0(5)=xmat0(6) 252 : ENDIF 253 : ELSE IF (INPLAS.EQ.12) THEN 254 : * chaboche 2 255 : ELSE IF (INPLAS.EQ.14) THEN 256 : IF(XMAT(8).NE.0.D0 .OR. XMAT(9).NE.0.D0) THEN 257 : INPLAS=18 258 : XMAT(5)=XMAT(8) 259 : XMAT(6)=XMAT(9) 260 : xmat0(5)=xmat0(8) 261 : xmat0(6)=xmat0(9) 262 : ENDIF 263 : ELSE IF(INPLAS.EQ.64) THEN 264 : C gurson2 265 : XSRMA=XMAT(3) 266 : XMAT(3)=XMAT(17) 267 : XMAT(17)=XMAT(4) 268 : XMAT(4)=XSRMA 269 : ENDIF 270 : ENDIF 271 : 272 : ENDIF 273 : * 274 : *----------------------------------------------------------- 275 : * rearrangement pour certaines formulations 276 : *----------------------------------------------------------- 277 : * cas milieu poreux 278 : * 279 : IF (MFRBI.EQ.33.AND.MATE.EQ.1) THEN 280 : ICAS=1 280 : CALL COMEFF(IQMOD,IWRK52,IWRK53,IWRK54,IECOU,ICAS,IRETOU) 281 : IF (iretou.NE.0) RETURN 282 : ENDIF 283 : * 284 : * cas des materiaux unidirectionnels 285 : * en plasticite 286 : * 287 : * ce qui suit est limité au coq2 et au dst 288 : * 289 : * on met v1x et v1y à la place de rho et alph 290 : * on met nu à 0. et on se decale ( on ignore les axes ) 291 : * 292 : * dans le cas des coq2, il faut aller chercher les contraintes 293 : * dans la direction ad-hoc. inutile pour le dst. 294 : * on se limite au cas axisymetrique ? 295 : * 296 : IF (MATE.EQ.4.AND.INPLAS.NE.0) THEN 297 : XMAT(3)=XMAT(2) 298 : xmat0(3)=xmat0(2) 299 : XMAT(2)=0.D0 300 : xmat0(2)=0.D0 301 : DO 1995 IC=4,NMATT-1 302 : XMAT(IC) = XMAT(IC+1) 303 : xmat0(IC) = xmat0(IC+1) 304 : 1995 CONTINUE 305 : * 306 : * coq2 : on change les contraintes de repere 307 : * les variables internes sont dans le repere unidirectionnel 308 : * 309 : IF (MELE.EQ.44) THEN 310 : DO 1996 I=1,NSTRS 311 : BID(I)=SIG0(I) 312 : BID2(I)=DSIGT(I) 313 : 1996 CONTINUE 314 : * 315 : ELSEIF(LUNI1)THEN 316 : V1X=TXR(1,1)*XMAT(3)+TXR(1,2)*XMAT(4) 317 : V1Y=TXR(2,1)*XMAT(3)+TXR(2,2)*XMAT(4) 318 : XMAT(3)=V1X 319 : XMAT(4)=V1Y 320 : * heu il faudrait peut etre revoir TXR . kich 321 : V1X=TXR(1,1)*xmat0(3)+TXR(1,2)*xmat0(4) 322 : V1Y=TXR(2,1)*xmat0(3)+TXR(2,2)*xmat0(4) 323 : xmat0(3)=V1X 324 : xmat0(4)=V1Y 325 : ELSEIF(LUNI2)THEN 326 : * 327 : ELSE 328 : RETURN 329 : ENDIF 330 : ENDIF 331 : * 332 : ENDIF 333 : * 334 : 335 : IF (MFRbi.EQ.27.OR.MFRbi.EQ.49) THEN 336 : * 337 : * on cherche la section de l'element ib 338 : * 339 : SECT = xcarb(1) 340 : * 341 : * prise en compte de l'epaisseur et de l'excentrement 342 : * dans le cas des coques minces avec ou sans cisaillement 343 : * transverse 344 : * 345 : ELSE IF (MFRbi.EQ.3.OR.MFRbi.EQ.9) THEN 346 : IF (CMATE.EQ.'ISOTROPE' .OR. CMATE.EQ.'ORTHOTRO' .OR. 347 : 1 CMATE.EQ.'UNIDIREC') 348 : 2 EPAIST = xcarb(1) 349 : ENDIF 350 : 351 : IF (INPLAS.EQ.29 .OR. INPLAS.EQ.26 .OR. INPLAS.EQ.142) THEN 352 : * 353 : * pour les materiaux endommageables de lemaitre traitement special 354 : * car ils peuvent dependre de la temperature 355 : * 356 : NTABO1 = 0 357 : NTABO2 = 0 358 : SEGINI WR10 359 : DO 2200 JC=1,NMATT 360 : IF (TYMAT(JC)(1:8).EQ.'REAL*8 ') THEN 361 : NTABO1=NTABO1+1 362 : NTABO2=NTABO2+1 363 : SEGADJ WR10 364 : IABLO1(NTABO1)=1 365 : TABLO2(NTABO2)=XMAT(JC) 366 : ELSE IF (TYMAT(JC)(9:16).EQ.'EVOLUTIO') THEN 367 : xmatjc = xmat(jc) 368 : ncoor=ncourb 368 : CALL KSISI1(xmatjc,JC,WRK2,Nccor,kerre7) 369 : IF (kerre7.NE.0) THEN 370 : KERRE = kerre7 371 : IRETOU = 1 372 : RETURN 373 : ENDIF 374 : ncourb=nccor 375 : NTABO1=NTABO1+1 376 : NTABO=NTABO2 377 : NTABO2=NTABO2+(2*NCOURB) 378 : SEGADJ WR10 379 : IABLO1(NTABO1)=2*NCOURB 380 : DO 2050 JCC=1,NCOURB 381 : TABLO2(NTABO+(2*JCC-1))=TRAC(2*JCC-1) 382 : TABLO2(NTABO+(2*JCC))=TRAC(2*JCC) 383 : 2050 continue 384 : ELSE IF (TYMAT(JC)(9:16).EQ.'NUAGE ') THEN 385 : NTABO3 = 0 386 : NTABO4 = 0 387 : SEGINI WR11 388 : xmatjc = xmat(jc) 388 : CALL XNUAG1(xmatjc,JC,WR11,NTABO3,NTABO4,kerre1) 389 : IF (kerre1.NE.0) THEN 390 : KERRE = kerre1 391 : SEGSUP WR10 392 : SEGSUP WR11 393 : KERR1=2 394 : IRETOU = 1 395 : RETURN 396 : ENDIF 397 : * segadj wr11 398 : NTABO=NTABO1 399 : NTABOO=NTABO2 400 : NTABO1=NTABO1+NTABO3+1 401 : NTABO2=NTABO2+NTABO4 402 : SEGADJ WR10 403 : IABLO1(NTABO+1)=NTABO3 404 : DO 2075 JCC=1,NTABO3 405 : 2075 iablo1(ntabo+1+jcc)=iablo3(jcc) 406 : DO 2125 JCC=1,NTABO4 407 : 2125 tablo2(ntaboo+jcc)=tablo4(jcc) 408 : SEGSUP WR11 409 : ENDIF 410 : 2200 continue 411 : ENDIF 412 : * 413 : * >>>>>>>>>> fin du traitement du materiau endommageables de lemaitre 414 : ** 415 : return 416 : 417 : C======================== 418 : C = AUTRES FORMULATIONS = 419 : C======================== 420 : 20 continue 421 : * if (formod(1).ne.'METALLURGIE') goto 130 422 : * return 423 : 424 : 130 continue 425 : 426 : RETURN 427 : END 428 : 429 :
© Cast3M 2003 - All rights reserved.
Disclaimer