C COMARA SOURCE OF166741 25/11/04 21:15:32 12349 SUBROUTINE COMARA(IQMOD,IWRK52,IWRK53,iwrk54,wrk2,wr10, & 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 PPARAM -INC CCOPTIO -INC SMMODEL -INC SMLREEL -INC SMCHAML -INC DECHE -INC TECOU SEGMENT WRK2 REAL*8 TRAC(LTRAC) ENDSEGMENT SEGMENT WR10 INTEGER IABLO1(NTABO1) REAL*8 TABLO2(NTABO2) ENDSEGMENT SEGMENT WR11 INTEGER IABLO3(NTABO3) REAL*8 TABLO4(NTABO4) ENDSEGMENT REAL*8 TTRAV(50) LOGICAL XLO imodel = iqmod wrk52 = iwrk52 wrk53 = iwrk53 wrk54 = iwrk54 xecou.DT = tempf - temp0 xecou.DTOPTI = 1.D6*xecou.DT xecou.DTT=xecou.DT xecou.TEMP00 = temp0 C========================================== C = CAS PARTICULIER : 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 = CAS GENERAL = C======================== MFRL = iecou.MFRBI JNPLAS = wrk53.INPLAS * write(6,*) 'comara ', MFRL, MFR C======================================== C = FORMULATIONS 'MECANIQUE' & 'POREUX' = C======================================== IF ((formod(1).EQ.'MECANIQUE ').OR. & (formod(1).EQ.'POREUX ')) THEN ncara = xmat(/1) do ic = 1,ncara XMAT (ic) = VALMAT(ic) xmat0(ic) = valma0(ic) enddo C C Poutre 3D C IF ((MFRL.EQ.7.or.MFRL.eq.27) .and. & cmatee.eq.'IMPELAST') THEN do ic = 1,12 if (xcarb(ic).eq.0.d0) xcarb(ic) = 1.D0 enddo xcarb(4) = 1.d0 if (inatuu.ne.161) valcar(4) = 1.D0 ENDIF IF (MFRL.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 ** write(6,*) 'comara icara ',icara if (xcarb(/1).ge.12) then vx = xcarb(7) vy = xcarb(8) vz = xcarb(9) ** write(6,*) 'comara icara vx vy vz',icara,vx,vy,vz XCARB(7)=XCARB(ICARA-2) XCARB(8)=XCARB(ICARA-1) XCARB(9)=XCARB(ICARA) NTTRAV = icara - 9 - idim do ic = 1, NTTRAV ttrav(ic) = xcarb(ic+9) enddo XCARB(10)=VX XCARB(11)=VY XCARB(12)=VZ do ic = 1,nttrav xcarb(12+ic) = ttrav(ic) enddo endif * 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 (MFRL.EQ.13) THEN NTTRAV = iecou.icara - idim - 3 DO IC=1,NTTRAV TTRAV(IC)=XCARB(IC+3) ENDDO IF (IDIM.EQ.2) THEN XCARB(4)=XCARB(iecou.ICARA-1) XCARB(5)=XCARB(iecou.ICARA) DO IC=1,NTTRAV XCARB(IC+5)=TTRAV(IC) ENDDO ELSE IF(IDIM.EQ.3)THEN XCARB(4)=XCARB(iecou.ICARA-2) XCARB(5)=XCARB(iecou.ICARA-1) XCARB(6)=XCARB(iecou.ICARA) DO IC=1,NTTRAV XCARB(IC+6)=TTRAV(IC) ENDDO ENDIF ENDIF * * cas des poutres en formulation section * IF ((MFRL.EQ.7.OR.MFRL.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(JNPLAS.EQ. 9.OR.JNPLAS.EQ.28.OR.JNPLAS.EQ.36.OR. & JNPLAS.EQ.42.OR.JNPLAS.EQ.66.OR.JNPLAS.EQ.74.OR. & JNPLAS.EQ.65.OR.JNPLAS.EQ.106.OR. & JNPLAS.EQ.107.OR.JNPLAS.EQ.108.OR. & JNPLAS.EQ.127.OR.JNPLAS.EQ.128.OR.JNPLAS.EQ.148.OR. & JNPLAS.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 JC=IC IF ((MFRL.EQ.1 .OR.MFRL.EQ.3 .OR. & MFRL.EQ.31.OR.MFRL.EQ.33) & .AND. IFOUR.EQ.-2) THEN IF(IC.GT.2.AND.IC.LT.NMATT-4) JC=IC+2 IF(IC.EQ.NMATT-4) JC=3 IF(IC.EQ.NMATT-3) JC=4 ELSE IF (CMATEE.EQ.'IMPELAST')THEN * kich impedance a completer selon inplas. par defaut : IF (IC.GE.2.AND.IC.LT.NMATT-4) JC = IC + 3 IF (IC.GE.NMATT-4 .AND. IC.LT.NMATT-2) JC = IC-NMATT+6 ELSE IF (JNPLAS.EQ.64)THEN C GURSON2 IF(IC.GT.2.AND.IC.LT.15) JC=IC+2 IF(IC.EQ.15) JC=3 IF(IC.EQ.16) JC=4 ELSE IF(IC.GT.2.AND.IC.LT.NMATT-3) JC=IC+2 IF(IC.EQ.NMATT-3) JC=3 IF(IC.EQ.NMATT-2) 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 * * necessaire pour hookis kich if (cmatee.eq.'IMPELAST'.and.inatuu.ne.161) then valmat(2) = xmat(2) valmat(NMATT-4) = xmat(NMATT-4) endif * rearrangement pour certaines lois cas elastique isotrope IF (JNPLAS.EQ.7) THEN * chaboche 1 ELSE IF (JNPLAS.EQ.2) THEN IF (XMAT(6).NE.0.D0) THEN C* Attention : on chnage INPLAS ! JNPLAS=27 INPLAS = JNPLAS XMAT(5)=XMAT(6) xmat0(5)=xmat0(6) ENDIF ELSE IF (JNPLAS.EQ.12) THEN * chaboche 2 CCC ELSE IF (JNPLAS.EQ.14) THEN CCC IF(XMAT(8).NE.0.D0 .OR. XMAT(9).NE.0.D0) THEN CCC JNPLAS=18 CCC INPLAS = JNPLAS CCC XMAT(5)=XMAT(8) CCC XMAT(6)=XMAT(9) CCC xmat0(5)=xmat0(8) CCC xmat0(6)=xmat0(9) CCC ENDIF ENDIF ENDIF ENDIF *----------------------------------------------------------- * rearrangement pour certaines formulations *----------------------------------------------------------- * cas milieu poreux * IF (MFRL.EQ.33.AND.MATE.EQ.1) THEN ICAS=1 CALL COMEFF(IQMOD,IWRK52,IWRK53,IWRK54,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.JNPLAS.NE.0) THEN XMAT(3)=XMAT(2) xmat0(3)=xmat0(2) XMAT(2)=0.D0 xmat0(2)=0.D0 DO IC=4,NMATT-1 XMAT(IC) = XMAT(IC+1) xmat0(IC) = xmat0(IC+1) ENDDO * * coq2 : on change les contraintes de repere * les variables internes sont dans le repere unidirectionnel * IF (MELE.EQ.44) THEN DO I=1,NSTRS BID(I)=SIG0(I) BID2(I)=DSIGT(I) ENDDO * 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 (MFRL.EQ.27.OR.MFRL.EQ.49) THEN * * on cherche la section de l'element courant if (xcarb(/1).gt.0) then SECT = xcarb(1) else sect=0.d0 endif if (cmatee.eq.'IMPELAST'.and.inatuu.ne.161) then SECT = 1.D0 xcarb(1) = 1.D0 endif * * prise en compte de l'epaisseur et de l'excentrement * dans le cas des coques minces avec ou sans cisaillement * transverse * ELSE IF (MFRL.EQ.3.OR.MFRL.EQ.9) THEN IF (CMATE.EQ.'ISOTROPE' .OR. CMATE.EQ.'ORTHOTRO' .OR. 1 CMATE.EQ.'UNIDIREC') 2 EPAIST = xcarb(1) ENDIF *---------------------------------------------------------------------- IF (JNPLAS.EQ.29 .OR. JNPLAS.EQ.26 .OR. JNPLAS.EQ.142) THEN * * pour les materiaux endommageables de lemaitre traitement special * car ils peuvent dependre de la temperature * NTABO1 = nmatt NTABO2 = nmatt + 2*ncourb NTABq1 = 0 NTABq2 = 0 if (wr10.eq.0) then * write(6,*) 'ini wr10',ntabo1,ntabo2 SEGINI WR10 endif DO 2200 JC=1,NMATT IF (TYMAT(JC)(1:8).EQ.'REAL*8 ') THEN NTABq1=NTABq1+1 NTABq2=NTABq2+1 if (ntabq1.gt.iablo1(/1)) ntabo1=ntabq1+64 if (ntabq2.gt.tablo2(/1)) ntabo2=ntabq2+64 if (ntabo1.gt.iablo1(/1).or.ntabo2.gt.tablo2(/1)) then * write(6,*) 'adj 1 wr10',ntabo1,ntabo2 SEGADJ WR10 endif IABLO1(NTABq1)=1 TABLO2(NTABq2)=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 NTABq1=NTABq1+1 NTABq=NTABq2 NTABq2=NTABq2+(2*NCOURB) if (ntabq1.gt.iablo1(/1)) ntabo1=ntabq1+64 if (ntabq2.gt.tablo2(/1)) ntabo2=ntabq2+64 if (ntabo1.gt.iablo1(/1).or.ntabo2.gt.tablo2(/1)) then * write(6,*) 'adj 2 wr10',ntabo1,ntabo2 SEGADJ WR10 endif IABLO1(NTABq1)=2*NCOURB DO JCC=1,NCOURB TABLO2(NTABq+(2*JCC-1))=TRAC(2*JCC-1) TABLO2(NTABq+(2*JCC))=TRAC(2*JCC) ENDDO 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 iecou.KERR1=2 IRETOU = 1 RETURN ENDIF * segadj wr11 NTABq=NTABq1 NTABqO=NTABq2 NTABq1=NTABq1+NTABO3+1 NTABq2=NTABq2+NTABO4 if (ntabq1.gt.iablo1(/1)) ntabo1=ntabq1+64 if (ntabq2.gt.tablo2(/1)) ntabo2=ntabq2+64 if (ntabo1.gt.iablo1(/1).or.ntabo2.gt.tablo2(/1)) then * write(6,*) 'adj 3 wr10',ntabo1,ntabo2 SEGADJ WR10 endif IABLO1(NTABq+1)=NTABO3 DO JCC=1,NTABO3 iablo1(ntabq+1+jcc)=iablo3(jcc) ENDDO DO JCC=1,NTABO4 tablo2(ntabqo+jcc)=tablo4(jcc) ENDDO SEGSUP WR11 ENDIF 2200 continue ENDIF C if (wr10.ne.0) then ntabo1=ntabq1 ntabo2=ntabq2 * write(6,*) 'comara nmatt ntabo1 ntabo2',nmatt,ntabo1,ntabo2 if (ntabo1.ne.iablo1(/1).or.ntabo2.ne.tablo2(/1)) then * write(6,*) 'adj 4 wr10 ',ntabo1,ntabo2 SEGADJ WR10 endif endif * * >>>>>>>>>> fin du traitement du materiau endommageables de lemaitre C======================== C = AUTRES FORMULATIONS = C======================== ELSE ncara = xmat(/1) do ic = 1,ncara XMAT (ic) = VALMAT(ic) xmat0(ic) = valma0(ic) enddo ENDIF RETURN END