Télécharger la plaquette Cast3M


fr en

Télécharger comara.eso

Retour à la liste

Numérotation des lignes : 

comara

  1. C COMARA    SOURCE    OF166741  25/11/04    21:15:32     12349          
  2.  
  3.       SUBROUTINE COMARA(IQMOD,IWRK52,IWRK53,iwrk54,wrk2,wr10,
  4.      &       iretou,necou,iecou,xecou,itruli)
  5. *----------------------------------------------------------
  6. * quelques manipulations de donnees
  7. *
  8. * MECANIQUE : rangements dans XMAT et VALMAT, compatibilite avec
  9. * la structure de ECOUL
  10. *
  11. * METALLURGIE : creation de nuages pour materiau CEREM
  12. *
  13. c pb kerr0
  14. *----------------------------------------------------------
  15.       IMPLICIT INTEGER(I-N)
  16.       IMPLICIT REAL*8(A-H,O-Z)
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC SMMODEL
  21. -INC SMLREEL
  22. -INC SMCHAML
  23. -INC DECHE
  24. -INC TECOU
  25.  
  26.       SEGMENT WRK2
  27.         REAL*8 TRAC(LTRAC)
  28.       ENDSEGMENT
  29.  
  30.       SEGMENT WR10
  31.         INTEGER IABLO1(NTABO1)
  32.         REAL*8  TABLO2(NTABO2)
  33.       ENDSEGMENT
  34.  
  35.       SEGMENT WR11
  36.         INTEGER IABLO3(NTABO3)
  37.         REAL*8  TABLO4(NTABO4)
  38.       ENDSEGMENT
  39.  
  40.       REAL*8 TTRAV(50)
  41.       LOGICAL XLO
  42.  
  43.       imodel = iqmod
  44.       wrk52 = iwrk52
  45.       wrk53 = iwrk53
  46.       wrk54 = iwrk54
  47.  
  48.       xecou.DT = tempf - temp0
  49.       xecou.DTOPTI = 1.D6*xecou.DT
  50.       xecou.DTT=xecou.DT
  51.       xecou.TEMP00 = temp0
  52.  
  53. C==========================================
  54. C = CAS PARTICULIER : FORMULATION LIAISON =
  55. C==========================================
  56.       if (itruli.gt.0) then
  57. * 1) suite d un calcul : directement dans coml10
  58. *  NEWMOD : nvari = 1 (cf. idvari.eso)
  59.         IF (mate.GE.23) RETURN
  60. *  Pour les autres types (mate = 1 a 22)  : nvari = 5
  61.         IF (var0(3).GT.0.D0 .AND. var0(4).GT.0.D0) RETURN
  62. * 2) dimensionnement (voir DYNE72) pour LIAISON
  63.         CALL CYNE72(iqmod,iwrk52,itruli)
  64.         IF (IERR.NE.0) RETURN
  65. * Les segments sont remplis (voir le s-p DEVLIA):
  66.         CALL cyne20(iqmod,iwrk52,itruli)
  67.         RETURN
  68.       ENDIF
  69.  
  70. C================
  71. C = CAS GENERAL =
  72. C========================
  73.       MFRL = iecou.MFRBI
  74.       JNPLAS = wrk53.INPLAS
  75. *     write(6,*) 'comara ', MFRL, MFR
  76.  
  77. C========================================
  78. C = FORMULATIONS 'MECANIQUE' & 'POREUX' =
  79. C========================================
  80.       IF ((formod(1).EQ.'MECANIQUE       ').OR.
  81.      &    (formod(1).EQ.'POREUX          ')) THEN
  82.  
  83.         ncara = xmat(/1)
  84.         do ic = 1,ncara
  85.           XMAT (ic) = VALMAT(ic)
  86.           xmat0(ic) = valma0(ic)
  87.         enddo
  88. C
  89. C Poutre 3D
  90. C
  91.         IF ((MFRL.EQ.7.or.MFRL.eq.27) .and.
  92.      &      cmatee.eq.'IMPELAST') THEN
  93.           do ic = 1,12
  94.             if (xcarb(ic).eq.0.d0) xcarb(ic) = 1.D0
  95.           enddo
  96.           xcarb(4) = 1.d0
  97.           if (inatuu.ne.161) valcar(4) = 1.D0
  98.         ENDIF
  99.  
  100.         IF (MFRL.EQ.7)THEN
  101. C
  102.           IF (IDIM.EQ.3)THEN
  103. C  distinction entre poutre bernouilli et poutre timo en ce qui
  104. C  concerne le defaut pour les sections reduites de l'effort tranchant
  105.             IF (MELE.EQ.84)THEN
  106.               SD=XCARB(4)
  107.               SREDY=XCARB(5)
  108.               SREDZ=XCARB(6)
  109.               IF(SREDY.EQ.0) XCARB(5)=SD
  110.               IF(SREDZ.EQ.0) XCARB(6)=SD
  111.             ENDIF
  112. *    rearrangement du tableau xcarB pour qu'on ait le meme ordre
  113. *    que l'ancien  chamelem
  114. **              write(6,*) 'comara icara ',icara
  115.             if (xcarb(/1).ge.12) then
  116.               vx = xcarb(7)
  117.               vy = xcarb(8)
  118.               vz = xcarb(9)
  119. **              write(6,*) 'comara icara vx vy vz',icara,vx,vy,vz
  120.               XCARB(7)=XCARB(ICARA-2)
  121.               XCARB(8)=XCARB(ICARA-1)
  122.               XCARB(9)=XCARB(ICARA)
  123.               NTTRAV = icara - 9 - idim
  124.               do ic = 1, NTTRAV
  125.                 ttrav(ic) = xcarb(ic+9)
  126.               enddo
  127.               XCARB(10)=VX
  128.               XCARB(11)=VY
  129.               XCARB(12)=VZ
  130.               do ic = 1,nttrav
  131.                 xcarb(12+ic) = ttrav(ic)
  132.               enddo
  133.             endif
  134. *
  135.           ELSE IF (IDIM.EQ.2.and.ncarr.ge.3) THEN
  136. C poutre 2D
  137. C  distinction entre poutre bernouilli et poutre timo en ce qui
  138. C  concerne le defaut pour les sections reduites de l'effort tranchant
  139.             SD=XCARB(1)
  140.             SREDY=XCARB(3)
  141.             IF(SREDY.EQ.0) XCARB(3)=SD
  142.           ENDIF
  143. *
  144.         ELSE IF (MFRL.EQ.13) THEN
  145.           NTTRAV = iecou.icara - idim - 3
  146.           DO IC=1,NTTRAV
  147.             TTRAV(IC)=XCARB(IC+3)
  148.           ENDDO
  149.           IF (IDIM.EQ.2) THEN
  150.             XCARB(4)=XCARB(iecou.ICARA-1)
  151.             XCARB(5)=XCARB(iecou.ICARA)
  152.             DO IC=1,NTTRAV
  153.               XCARB(IC+5)=TTRAV(IC)
  154.             ENDDO
  155.           ELSE IF(IDIM.EQ.3)THEN
  156.             XCARB(4)=XCARB(iecou.ICARA-2)
  157.             XCARB(5)=XCARB(iecou.ICARA-1)
  158.             XCARB(6)=XCARB(iecou.ICARA)
  159.             DO IC=1,NTTRAV
  160.               XCARB(IC+6)=TTRAV(IC)
  161.             ENDDO
  162.           ENDIF
  163.         ENDIF
  164.  
  165. *
  166. *     cas des poutres en formulation section
  167. *
  168.         IF ((MFRL.EQ.7.OR.MFRL.EQ.13).AND.
  169.      1      CMATE.EQ.'SECTION ') THEN
  170. *
  171. * >>>>>>>>>>  cas des materiaux elastiques isotropes
  172. *                                       ou unidirectionnels
  173. *
  174.         ELSE IF(MATE.EQ.1.OR.MATE.EQ.4) THEN
  175.           IF(JNPLAS.EQ. 9.OR.JNPLAS.EQ.28.OR.JNPLAS.EQ.36.OR.
  176.      &       JNPLAS.EQ.42.OR.JNPLAS.EQ.66.OR.JNPLAS.EQ.74.OR.
  177.      &       JNPLAS.EQ.65.OR.JNPLAS.EQ.106.OR.
  178.      &       JNPLAS.EQ.107.OR.JNPLAS.EQ.108.OR.
  179.      &       JNPLAS.EQ.127.OR.JNPLAS.EQ.128.OR.JNPLAS.EQ.148.OR.
  180.      &       JNPLAS.LT.0) THEN
  181. *             pour les modeles beton et ubiquitous
  182. *             et ceux dont on ne remodifie pas l'ordre
  183.           ELSE
  184. *
  185.             XLO=.TRUE.
  186.             IF (MELE.GE.108 .AND.MELE.LE.110) XLO=.FALSE.
  187.             IF (MFR .EQ.33  .AND.MATE.NE.1  ) XLO=.FALSE.
  188.             IF (MFR .EQ.57  .OR. MFR .EQ.59 ) XLO=.FALSE.
  189. *
  190. *               on saute des elements n'ayant pas ALPH  et RHO
  191. *
  192.             IF (XLO) THEN
  193. *           pour les autres modeles :
  194. *           on a les noms : e,nu,puis le reste des obligatoires
  195. *           puis les facultatives qui se terminent par rho et alph
  196. *           d'apres un rangement dans idmatr
  197. *           dans le remplissage de xmat, on veut e,nu,rho,alph
  198. *           puis la suite. d'ou ce qui suit ....
  199. *  am 9/11/93  a reprendre  !!
  200. *  am 28/7/95  le commentaire ci dessus est FAUX si l'on a des
  201. *              proprietes facultatives en plus de rho et alph
  202. *              car dans ce cas les facultatives COMMENCENT par
  203. *              rho et alph.   a reprendre  !!!!!!!!
  204.               DO 1106  IC=1,NMATT
  205.                 JC=IC
  206.                 IF ((MFRL.EQ.1 .OR.MFRL.EQ.3 .OR.
  207.      &               MFRL.EQ.31.OR.MFRL.EQ.33)
  208.      &             .AND. IFOUR.EQ.-2) THEN
  209.                   IF(IC.GT.2.AND.IC.LT.NMATT-4) JC=IC+2
  210.                   IF(IC.EQ.NMATT-4) JC=3
  211.                   IF(IC.EQ.NMATT-3) JC=4
  212.  
  213.                 ELSE IF (CMATEE.EQ.'IMPELAST')THEN
  214. *                    kich impedance a completer selon inplas. par defaut :
  215.                   IF (IC.GE.2.AND.IC.LT.NMATT-4) JC = IC + 3
  216.                   IF (IC.GE.NMATT-4 .AND. IC.LT.NMATT-2) JC = IC-NMATT+6
  217.  
  218.                 ELSE IF (JNPLAS.EQ.64)THEN
  219. C                   GURSON2
  220.                   IF(IC.GT.2.AND.IC.LT.15) JC=IC+2
  221.                   IF(IC.EQ.15) JC=3
  222.                   IF(IC.EQ.16) JC=4
  223.                 ELSE
  224.                   IF(IC.GT.2.AND.IC.LT.NMATT-3) JC=IC+2
  225.                   IF(IC.EQ.NMATT-3) JC=3
  226.                   IF(IC.EQ.NMATT-2) JC=4
  227.                 ENDIF
  228.                 XMAT(jc) = VALMAT(ic)
  229.                 xmat0(jc)= valma0(ic)
  230. * le tableau tymat de WRK54 est relatif a XMAT et xma0
  231.                 tymat(jc) = tyval(ic)
  232. c                 PRINT *,'XMAT(',JC,')=',XMAT(JC),tymat(jc)
  233. 1106          continue
  234. *
  235. *       necessaire pour hookis kich
  236.               if (cmatee.eq.'IMPELAST'.and.inatuu.ne.161) then
  237.                 valmat(2) = xmat(2)
  238.                 valmat(NMATT-4) = xmat(NMATT-4)
  239.               endif
  240.  
  241. *        rearrangement pour  certaines lois cas elastique isotrope
  242.               IF (JNPLAS.EQ.7) THEN
  243. *                                            chaboche 1
  244.               ELSE IF (JNPLAS.EQ.2) THEN
  245.                 IF (XMAT(6).NE.0.D0) THEN
  246. C* Attention : on chnage INPLAS !
  247.                   JNPLAS=27
  248.                   INPLAS = JNPLAS
  249.                   XMAT(5)=XMAT(6)
  250.                   xmat0(5)=xmat0(6)
  251.                 ENDIF
  252.               ELSE IF (JNPLAS.EQ.12) THEN
  253. *                                            chaboche 2
  254. CCC              ELSE IF (JNPLAS.EQ.14) THEN
  255. CCC                IF(XMAT(8).NE.0.D0 .OR. XMAT(9).NE.0.D0) THEN
  256. CCC                  JNPLAS=18
  257. CCC                  INPLAS = JNPLAS
  258. CCC                  XMAT(5)=XMAT(8)
  259. CCC                  XMAT(6)=XMAT(9)
  260. CCC                  xmat0(5)=xmat0(8)
  261. CCC                  xmat0(6)=xmat0(9)
  262. CCC                ENDIF
  263.               ENDIF
  264.             ENDIF
  265.  
  266.           ENDIF
  267.  
  268. *-----------------------------------------------------------
  269. *        rearrangement pour  certaines formulations
  270. *-----------------------------------------------------------
  271. *          cas  milieu poreux
  272. *
  273.           IF (MFRL.EQ.33.AND.MATE.EQ.1) THEN
  274.             ICAS=1
  275.             CALL COMEFF(IQMOD,IWRK52,IWRK53,IWRK54,ICAS,IRETOU)
  276.             IF (iretou.NE.0) RETURN
  277.           ENDIF
  278. *
  279. *       cas des materiaux unidirectionnels
  280. *                en plasticite
  281. *
  282. *      ce qui suit est limité au coq2 et au dst
  283. *
  284. *      on met v1x et v1y à la place de rho et alph
  285. *      on met nu à 0. et on se decale ( on ignore les axes )
  286. *
  287. *      dans le cas des coq2, il faut aller chercher les contraintes
  288. *      dans la direction ad-hoc. inutile pour le dst.
  289. *      on se limite au cas axisymetrique ?
  290. *
  291.           IF (MATE.EQ.4.AND.JNPLAS.NE.0) THEN
  292.             XMAT(3)=XMAT(2)
  293.             xmat0(3)=xmat0(2)
  294.             XMAT(2)=0.D0
  295.             xmat0(2)=0.D0
  296.             DO IC=4,NMATT-1
  297.               XMAT(IC) = XMAT(IC+1)
  298.               xmat0(IC) = xmat0(IC+1)
  299.             ENDDO
  300. *
  301. *   coq2  : on change les contraintes de repere
  302. *       les variables internes sont dans le repere unidirectionnel
  303. *
  304.             IF (MELE.EQ.44) THEN
  305.               DO I=1,NSTRS
  306.                 BID(I)=SIG0(I)
  307.                 BID2(I)=DSIGT(I)
  308.               ENDDO
  309. *
  310.             ELSEIF(LUNI1)THEN
  311.               V1X=TXR(1,1)*XMAT(3)+TXR(1,2)*XMAT(4)
  312.               V1Y=TXR(2,1)*XMAT(3)+TXR(2,2)*XMAT(4)
  313.               XMAT(3)=V1X
  314.               XMAT(4)=V1Y
  315. * heu il faudrait peut etre revoir TXR . kich
  316.               V1X=TXR(1,1)*xmat0(3)+TXR(1,2)*xmat0(4)
  317.               V1Y=TXR(2,1)*xmat0(3)+TXR(2,2)*xmat0(4)
  318.               xmat0(3)=V1X
  319.               xmat0(4)=V1Y
  320.             ELSEIF(LUNI2)THEN
  321. *
  322.             ELSE
  323.               RETURN
  324.             ENDIF
  325.           ENDIF
  326. *
  327.         ENDIF
  328. *
  329. *----------------------------------------------------------------------
  330.         IF (MFRL.EQ.27.OR.MFRL.EQ.49) THEN
  331. *
  332. *  on cherche la section de l'element courant
  333.           if (xcarb(/1).gt.0) then
  334.             SECT = xcarb(1)
  335.           else
  336.             sect=0.d0
  337.           endif
  338.           if (cmatee.eq.'IMPELAST'.and.inatuu.ne.161) then
  339.             SECT = 1.D0
  340.             xcarb(1) = 1.D0
  341.           endif
  342. *
  343. *  prise en compte de l'epaisseur et de l'excentrement
  344. *  dans le cas des coques minces avec ou sans cisaillement
  345. *  transverse
  346. *
  347.         ELSE IF (MFRL.EQ.3.OR.MFRL.EQ.9) THEN
  348.           IF (CMATE.EQ.'ISOTROPE' .OR. CMATE.EQ.'ORTHOTRO' .OR.
  349.      1        CMATE.EQ.'UNIDIREC')
  350.      2      EPAIST = xcarb(1)
  351.         ENDIF
  352.  
  353. *----------------------------------------------------------------------
  354.         IF (JNPLAS.EQ.29 .OR. JNPLAS.EQ.26 .OR. JNPLAS.EQ.142) THEN
  355. *
  356. *        pour les materiaux endommageables de lemaitre traitement special
  357. *        car ils peuvent dependre de la temperature
  358. *
  359.           NTABO1 = nmatt
  360.           NTABO2 = nmatt + 2*ncourb
  361.           NTABq1 = 0
  362.           NTABq2 = 0
  363.           if (wr10.eq.0) then
  364. *          write(6,*) 'ini wr10',ntabo1,ntabo2
  365.             SEGINI WR10
  366.           endif
  367.           DO 2200 JC=1,NMATT
  368.             IF (TYMAT(JC)(1:8).EQ.'REAL*8  ') THEN
  369.               NTABq1=NTABq1+1
  370.               NTABq2=NTABq2+1
  371.               if (ntabq1.gt.iablo1(/1)) ntabo1=ntabq1+64
  372.               if (ntabq2.gt.tablo2(/1)) ntabo2=ntabq2+64
  373.               if (ntabo1.gt.iablo1(/1).or.ntabo2.gt.tablo2(/1)) then
  374. *                write(6,*) 'adj 1 wr10',ntabo1,ntabo2
  375.                 SEGADJ WR10
  376.               endif
  377.               IABLO1(NTABq1)=1
  378.               TABLO2(NTABq2)=XMAT(JC)
  379.             ELSE IF (TYMAT(JC)(9:16).EQ.'EVOLUTIO') THEN
  380.               xmatjc  = xmat(jc)
  381.               ncoor=ncourb
  382.               CALL KSISI1(xmatjc,JC,WRK2,Nccor,kerre7)
  383.               IF (kerre7.NE.0) THEN
  384.                 KERRE = kerre7
  385.                 IRETOU = 1
  386.                 RETURN
  387.               ENDIF
  388.               ncourb=nccor
  389.               NTABq1=NTABq1+1
  390.               NTABq=NTABq2
  391.               NTABq2=NTABq2+(2*NCOURB)
  392.               if (ntabq1.gt.iablo1(/1))  ntabo1=ntabq1+64
  393.               if (ntabq2.gt.tablo2(/1))  ntabo2=ntabq2+64
  394.               if (ntabo1.gt.iablo1(/1).or.ntabo2.gt.tablo2(/1)) then
  395. *                write(6,*) 'adj 2 wr10',ntabo1,ntabo2
  396.                 SEGADJ WR10
  397.               endif
  398.               IABLO1(NTABq1)=2*NCOURB
  399.               DO JCC=1,NCOURB
  400.                 TABLO2(NTABq+(2*JCC-1))=TRAC(2*JCC-1)
  401.                 TABLO2(NTABq+(2*JCC))=TRAC(2*JCC)
  402.               ENDDO
  403.             ELSE IF (TYMAT(JC)(9:16).EQ.'NUAGE   ') THEN
  404.               NTABO3 = 0
  405.               NTABO4 = 0
  406.               SEGINI WR11
  407.               xmatjc  = xmat(jc)
  408.               CALL XNUAG1(xmatjc,JC,WR11,NTABO3,NTABO4,kerre1)
  409.               IF (kerre1.NE.0) THEN
  410.                 KERRE = kerre1
  411.                 SEGSUP WR10
  412.                 SEGSUP WR11
  413.                 iecou.KERR1=2
  414.                 IRETOU = 1
  415.                 RETURN
  416.               ENDIF
  417. *              segadj wr11
  418.               NTABq=NTABq1
  419.               NTABqO=NTABq2
  420.               NTABq1=NTABq1+NTABO3+1
  421.               NTABq2=NTABq2+NTABO4
  422.               if (ntabq1.gt.iablo1(/1))  ntabo1=ntabq1+64
  423.               if (ntabq2.gt.tablo2(/1))  ntabo2=ntabq2+64
  424.               if (ntabo1.gt.iablo1(/1).or.ntabo2.gt.tablo2(/1)) then
  425. *                write(6,*) 'adj 3 wr10',ntabo1,ntabo2
  426.                 SEGADJ WR10
  427.               endif
  428.               IABLO1(NTABq+1)=NTABO3
  429.               DO JCC=1,NTABO3
  430.                 iablo1(ntabq+1+jcc)=iablo3(jcc)
  431.               ENDDO
  432.               DO JCC=1,NTABO4
  433.                 tablo2(ntabqo+jcc)=tablo4(jcc)
  434.               ENDDO
  435.               SEGSUP WR11
  436.             ENDIF
  437. 2200      continue
  438.         ENDIF
  439. C
  440.         if (wr10.ne.0) then
  441.           ntabo1=ntabq1
  442.           ntabo2=ntabq2
  443. *          write(6,*) 'comara nmatt ntabo1 ntabo2',nmatt,ntabo1,ntabo2
  444.           if (ntabo1.ne.iablo1(/1).or.ntabo2.ne.tablo2(/1)) then
  445. *            write(6,*) 'adj 4 wr10 ',ntabo1,ntabo2
  446.             SEGADJ WR10
  447.           endif
  448.         endif
  449. *
  450. * >>>>>>>>>>   fin du traitement du materiau endommageables de lemaitre
  451.  
  452. C========================
  453. C = AUTRES FORMULATIONS =
  454. C========================
  455.       ELSE
  456.         ncara = xmat(/1)
  457.         do ic = 1,ncara
  458.           XMAT (ic) = VALMAT(ic)
  459.           xmat0(ic) = valma0(ic)
  460.         enddo
  461.       ENDIF
  462.  
  463.       RETURN
  464.       END
  465.  
  466.  
  467.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales