C COMARA SOURCE FANDEUR 12/07/18 21:15:00 7435 SUBROUTINE COMARA(IQMOD,IWRK52,IWRK53,iwrk54,wrk2,wr10,ib,igau, & iretou,necou,iecou,xecou,itruli) *---------------------------------------------------------- * quelques manipulations de donnees * * MECANIQUE : rangements dans XMAT et VALMAT, compatibilite avec * la structure de ECOUL * * METALLURGIE : creation de nuages pour materiau CEREM * c pb kerr0 *---------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC CCOPTIO -INC SMMODEL -INC SMLREEL -INC SMCHAML -INC DECHE * SEGMENT WRK2 REAL*8 TRAC(LTRAC) ENDSEGMENT * ********* SEGMENT WRKTRA REAL*8 TTRAV(50) ********* ENDSEGMENT * SEGMENT WR10 INTEGER IABLO1(NTABO1) REAL*8 TABLO2(NTABO2) ENDSEGMENT * SEGMENT WR11 INTEGER IABLO3(NTABO3) REAL*8 TABLO4(NTABO4) ENDSEGMENT * * Segment NECOU utilisé dans ECOINC * SEGMENT NECOU INTEGER NCOURB,IPLAST,IT,IMAPLA,ISOTRO, . ITYP,IFOURB,IFLUAG, . ICINE,ITHER,IFLUPL,ICYCL,IBI, . JFLUAG,KFLUAG,LFLUAG, . IRELAX,JNTRIN,MFLUAG,JSOUFL,JGRDEF ENDSEGMENT * * Segment IECOU: sert de fourre-tout pour les initialisations * d'entiers * SEGMENT IECOU INTEGER NYOG,NYNU,NYALFA,NYSMAX,NYN,NYM,NYKK,NYALF1, . NYBET1,NYR,NYA,NYRHO,NSIGY,NNKX,NYKX,IND,NSOM,NINV, . NINCMA,NCOMP,JELEM,LEGAUS,INAT,NCXMAT,LTRAC,MFRBI, . IELE,NHRM,NBNNBI,NBELMB,ICARA,LW2BI,NDEF,NSTRSS, . MFR1,NBGMAT,NELMAT,MSOUPA,NUMAT1,LENDO,NBBB,NNVARI, . KERR1,MELEMB,NYOG1,NYNU1,NYALFT1,NYSMAX1,NYN1,NYM1, . NYKK1,NYALF2,NYBET2,NYR1,NYA1,NYQ1,NYRHO1,NSIGY1 ENDSEGMENT * * Segment XECOU: sert de fourre-tout pour les initialisations * de réels * SEGMENT XECOU REAL*8 DTOPTI,TSOM,TCAR,DTT,DT,TREFA,TEMP00 ENDSEGMENT * LOGICAL XLO,DLIA * imodel = iqmod wrk52 = iwrk52 ****** segact wrk52*mod wrk53 = iwrk53 ******** segact wrk53*mod wrk54=iwrk54 DTOPTI = 1.D6*DT DTT=DT TEMP00 = temp0 C======================== C = FORMULATION LIAISON = C======================== if (itruli.gt.0) then * 1) suite d un calcul : directement dans coml10 * NEWMOD : nvari = 1 (cf. idvari.eso) IF (mate.GE.23) RETURN * Pour les autres types (mate = 1 a 22) : nvari = 5 IF (var0(3).GT.0.D0 .AND. var0(4).GT.0.D0) RETURN * 2) dimensionnement (voir DYNE72) pour LIAISON CALL CYNE72(iqmod,iwrk52,itruli) IF (IERR.NE.0) RETURN * * Les segments sont remplis (voir le s-p DEVLIA): * CALL cyne20(iqmod,iwrk52,itruli) RETURN ENDIF C======================== C = AUTRES FORMULATIONS = C======================== * write(6,*) 'comara ', mfrbi, MFR ncara = xmat(/1) do ic = 1,ncara XMAT(ic) = VALMAT(ic) xmat0(ic) = valma0(ic) enddo IF ((formod(1).NE.'MECANIQUE').AND. & (formod(1).NE.'POREUX')) GOTO 20 C======================================== C = FORMULATIONS 'MECANIQUE' & 'POREUX' = C======================================== C C Poutre 3D C IF (MFRbi.EQ.7)THEN C IF (IDIM.EQ.3)THEN C distinction entre poutre bernouilli et poutre timo en ce qui C concerne le defaut pour les sections reduites de l'effort tranchant IF(MELE.EQ.84)THEN SD=XCARB(4) SREDY=XCARB(5) SREDZ=XCARB(6) IF(SREDY.EQ.0) XCARB(5)=SD IF(SREDZ.EQ.0) XCARB(6)=SD ENDIF * rearrangement du tableau xcarB pour qu'on ait le meme ordre * que l'ancien chamelem vx = xcarb(7) vy = xcarb(8) vz = xcarb(9) XCARB(7)=XCARB(ICARA-2) XCARB(8)=XCARB(ICARA-1) XCARB(9)=XCARB(ICARA) NTTRAV = icara - 9 - idim do ic =10,icara - idim ttrav(ic - 9) = xcarb(ic) enddo XCARB(10)=VX XCARB(11)=VY XCARB(12)=VZ do ic = 1,nttrav xcarb(12+ic) = ttrav(ic) enddo * ELSE IF (IDIM.EQ.2.and.ncarr.ge.3) THEN C poutre 2D C distinction entre poutre bernouilli et poutre timo en ce qui C concerne le defaut pour les sections reduites de l'effort tranchant SD=XCARB(1) SREDY=XCARB(3) IF(SREDY.EQ.0) XCARB(3)=SD ENDIF * ELSE IF(MFRbi.EQ.13)THEN NTTRAV = icara - idim - 3 DO 1111 IC=4,icara - idim TTRAV(IC-3)=XCARB(IC) 1111 continue IF(IDIM.EQ.2)THEN XCARB(4)=XCARB(ICARA-1) XCARB(5)=XCARB(ICARA) DO 1112 IC=1,NTTRAV XCARB(IC+5)=TTRAV(IC) 1112 continue ELSE IF(IDIM.EQ.3)THEN XCARB(4)=XCARB(ICARA-2) XCARB(5)=XCARB(ICARA-1) XCARB(6)=XCARB(ICARA) DO 1113 IC=1,NTTRAV XCARB(IC+6)=TTRAV(IC) 1113 continue ENDIF ENDIF * * cas des poutres en formulation section * IF ((MFRbi.EQ.7.OR.MFRbi.EQ.13).AND. 1 CMATE.EQ.'SECTION') THEN * * >>>>>>>>>> cas des materiaux elastiques isotropes * ou unidirectionnels * ELSE IF(MATE.EQ.1.OR.MATE.EQ.4) THEN IF(INPLAS.EQ. 9.OR.INPLAS.EQ.28.OR.INPLAS.EQ.36.OR. & INPLAS.EQ.42.OR.INPLAS.EQ.66.OR.INPLAS.EQ.74.OR. & INPLAS.EQ.65.OR.INPLAS.EQ.106.OR. & INPLAS.EQ.107.OR.INPLAS.EQ.108.OR. & INPLAS.EQ.127.OR.INPLAS.EQ.128.OR. & INPLAS.LT.0) THEN * * pour les modeles beton et ubiquitous * et ceux dont on ne remodifie pas l'ordre * ELSE * XLO=.TRUE. IF(MELE.GE.108.AND.MELE.LE.110) XLO=.FALSE. IF(MFR.EQ.33.AND.MATE.NE.1) XLO=.FALSE. IF(MFR.EQ.57.OR.MFR.EQ.59) XLO=.FALSE. * * on saute des elements n'ayant pas ALPH et RHO * IF(XLO) THEN * pour les autres modeles : * on a les noms : e,nu,puis le reste des obligatoires * puis les facultatives qui se terminent par rho et alph * d'apres un rangement dans idmatr * dans le remplissage de xmat, on veut e,nu,rho,alph * puis la suite. d'ou ce qui suit .... * am 9/11/93 a reprendre !! * am 28/7/95 le commentaire ci dessus est FAUX si l'on a des * proprietes facultatives en plus de rho et alph * car dans ce cas les facultatives COMMENCENT par * rho et alph. a reprendre !!!!!!!! * DO 1106 IC=1,NMATT IF ((MFRbi.EQ.1.OR.MFRbi.EQ.3.OR.MFRbi.EQ.31 + .OR.MFRbi.EQ.33).AND.IFOUR.EQ.-2) THEN IF(IC.LE.2.OR.IC.EQ.NMATT) JC=IC IF(IC.GT.2.AND.IC.LT.NMATT-2) JC=IC+2 IF(IC.EQ.NMATT-2) JC=3 IF(IC.EQ.NMATT-1) JC=4 ELSE IF(IC.LE.2) JC=IC IF(IC.GT.2.AND.IC.LT.NMATT-1) JC=IC+2 IF(IC.EQ.NMATT-1) JC=3 IF(IC.EQ.NMATT) JC=4 ENDIF XMAT(jc) = VALMAT(ic) xmat0(jc) = valma0(ic) * le tableau tymat de WRK54 est relatif a XMAT et xma0 tymat(jc) = tyval(ic) c PRINT *,'XMAT(',JC,')=',XMAT(JC),tymat(jc) 1106 continue * * rearrangement pour certaines lois cas elastique isotrope * IF (INPLAS.EQ.7) THEN * chaboche 1 ELSE IF (INPLAS.EQ.2) THEN IF (XMAT(6).NE.0.D0) THEN INPLAS=27 XMAT(5)=XMAT(6) xmat0(5)=xmat0(6) ENDIF ELSE IF (INPLAS.EQ.12) THEN * chaboche 2 ELSE IF (INPLAS.EQ.14) THEN IF(XMAT(8).NE.0.D0 .OR. XMAT(9).NE.0.D0) THEN INPLAS=18 XMAT(5)=XMAT(8) XMAT(6)=XMAT(9) xmat0(5)=xmat0(8) xmat0(6)=xmat0(9) ENDIF ELSE IF(INPLAS.EQ.64) THEN C gurson2 XSRMA=XMAT(3) XMAT(3)=XMAT(17) XMAT(17)=XMAT(4) XMAT(4)=XSRMA ENDIF ENDIF ENDIF * *----------------------------------------------------------- * rearrangement pour certaines formulations *----------------------------------------------------------- * cas milieu poreux * IF (MFRBI.EQ.33.AND.MATE.EQ.1) THEN ICAS=1 CALL COMEFF(IQMOD,IWRK52,IWRK53,IWRK54,IECOU,ICAS,IRETOU) IF (iretou.NE.0) RETURN ENDIF * * cas des materiaux unidirectionnels * en plasticite * * ce qui suit est limité au coq2 et au dst * * on met v1x et v1y à la place de rho et alph * on met nu à 0. et on se decale ( on ignore les axes ) * * dans le cas des coq2, il faut aller chercher les contraintes * dans la direction ad-hoc. inutile pour le dst. * on se limite au cas axisymetrique ? * IF (MATE.EQ.4.AND.INPLAS.NE.0) THEN XMAT(3)=XMAT(2) xmat0(3)=xmat0(2) XMAT(2)=0.D0 xmat0(2)=0.D0 DO 1995 IC=4,NMATT-1 XMAT(IC) = XMAT(IC+1) xmat0(IC) = xmat0(IC+1) 1995 CONTINUE * * coq2 : on change les contraintes de repere * les variables internes sont dans le repere unidirectionnel * IF (MELE.EQ.44) THEN DO 1996 I=1,NSTRS BID(I)=SIG0(I) BID2(I)=DSIGT(I) 1996 CONTINUE * ELSEIF(LUNI1)THEN V1X=TXR(1,1)*XMAT(3)+TXR(1,2)*XMAT(4) V1Y=TXR(2,1)*XMAT(3)+TXR(2,2)*XMAT(4) XMAT(3)=V1X XMAT(4)=V1Y * heu il faudrait peut etre revoir TXR . kich V1X=TXR(1,1)*xmat0(3)+TXR(1,2)*xmat0(4) V1Y=TXR(2,1)*xmat0(3)+TXR(2,2)*xmat0(4) xmat0(3)=V1X xmat0(4)=V1Y ELSEIF(LUNI2)THEN * ELSE RETURN ENDIF ENDIF * ENDIF * IF (MFRbi.EQ.27.OR.MFRbi.EQ.49) THEN * * on cherche la section de l'element ib * SECT = xcarb(1) * * prise en compte de l'epaisseur et de l'excentrement * dans le cas des coques minces avec ou sans cisaillement * transverse * ELSE IF (MFRbi.EQ.3.OR.MFRbi.EQ.9) THEN IF (CMATE.EQ.'ISOTROPE' .OR. CMATE.EQ.'ORTHOTRO' .OR. 1 CMATE.EQ.'UNIDIREC') 2 EPAIST = xcarb(1) ENDIF IF (INPLAS.EQ.29 .OR. INPLAS.EQ.26 .OR. INPLAS.EQ.142) THEN * * pour les materiaux endommageables de lemaitre traitement special * car ils peuvent dependre de la temperature * NTABO1 = 0 NTABO2 = 0 SEGINI WR10 DO 2200 JC=1,NMATT IF (TYMAT(JC)(1:8).EQ.'REAL*8 ') THEN NTABO1=NTABO1+1 NTABO2=NTABO2+1 SEGADJ WR10 IABLO1(NTABO1)=1 TABLO2(NTABO2)=XMAT(JC) ELSE IF (TYMAT(JC)(9:16).EQ.'EVOLUTIO') THEN xmatjc = xmat(jc) ncoor=ncourb CALL KSISI1(xmatjc,JC,WRK2,Nccor,kerre7) IF (kerre7.NE.0) THEN KERRE = kerre7 IRETOU = 1 RETURN ENDIF ncourb=nccor NTABO1=NTABO1+1 NTABO=NTABO2 NTABO2=NTABO2+(2*NCOURB) SEGADJ WR10 IABLO1(NTABO1)=2*NCOURB DO 2050 JCC=1,NCOURB TABLO2(NTABO+(2*JCC-1))=TRAC(2*JCC-1) TABLO2(NTABO+(2*JCC))=TRAC(2*JCC) 2050 continue ELSE IF (TYMAT(JC)(9:16).EQ.'NUAGE ') THEN NTABO3 = 0 NTABO4 = 0 SEGINI WR11 xmatjc = xmat(jc) CALL XNUAG1(xmatjc,JC,WR11,NTABO3,NTABO4,kerre1) IF (kerre1.NE.0) THEN KERRE = kerre1 SEGSUP WR10 SEGSUP WR11 KERR1=2 IRETOU = 1 RETURN ENDIF * segadj wr11 NTABO=NTABO1 NTABOO=NTABO2 NTABO1=NTABO1+NTABO3+1 NTABO2=NTABO2+NTABO4 SEGADJ WR10 IABLO1(NTABO+1)=NTABO3 DO 2075 JCC=1,NTABO3 2075 iablo1(ntabo+1+jcc)=iablo3(jcc) DO 2125 JCC=1,NTABO4 2125 tablo2(ntaboo+jcc)=tablo4(jcc) SEGSUP WR11 ENDIF 2200 continue ENDIF * * >>>>>>>>>> fin du traitement du materiau endommageables de lemaitre ** return C======================== C = AUTRES FORMULATIONS = C======================== 20 continue * if (formod(1).ne.'METALLURGIE') goto 130 * return 130 continue RETURN END