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

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