Télécharger comara.eso

Retour à la liste

Numérotation des lignes :

  1. C COMARA SOURCE PV 17/10/09 21:15:02 9588
  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
  94. CALL CYNE72(iqmod,iwrk52,itruli)
  95. IF (IERR.NE.0) RETURN
  96. *
  97. * Les segments sont remplis (voir le s-p DEVLIA):
  98. *
  99. CALL cyne20(iqmod,iwrk52,itruli)
  100. RETURN
  101. ENDIF
  102.  
  103. C========================
  104. C = AUTRES FORMULATIONS =
  105. C========================
  106. * write(6,*) 'comara ', mfrbi, MFR
  107. ncara = xmat(/1)
  108. do ic = 1,ncara
  109. XMAT(ic) = VALMAT(ic)
  110. xmat0(ic) = valma0(ic)
  111. enddo
  112.  
  113. IF ((formod(1).NE.'MECANIQUE').AND.
  114. & (formod(1).NE.'POREUX')) GOTO 20
  115.  
  116. C========================================
  117. C = FORMULATIONS 'MECANIQUE' & 'POREUX' =
  118. C========================================
  119. C
  120. C Poutre 3D
  121. C
  122. IF ((MFRbi.EQ.7.or.MFRbi.eq.27).and.cmatee.eq.'IMPELAST') THEN
  123. do ic = 1,12
  124. if (xcarb(ic).eq.0.d0) xcarb(ic) = 1.D0
  125. enddo
  126. xcarb(4) = 1.d0
  127. if (inatuu.ne.161) then
  128. valcar(4) = 1.D0
  129. endif
  130. ENDIF
  131.  
  132. IF (MFRbi.EQ.7)THEN
  133. C
  134. IF (IDIM.EQ.3)THEN
  135. C distinction entre poutre bernouilli et poutre timo en ce qui
  136. C concerne le defaut pour les sections reduites de l'effort tranchant
  137. IF(MELE.EQ.84)THEN
  138. SD=XCARB(4)
  139. SREDY=XCARB(5)
  140. SREDZ=XCARB(6)
  141. IF(SREDY.EQ.0) XCARB(5)=SD
  142. IF(SREDZ.EQ.0) XCARB(6)=SD
  143. ENDIF
  144. * rearrangement du tableau xcarB pour qu'on ait le meme ordre
  145. * que l'ancien chamelem
  146. vx = xcarb(7)
  147. vy = xcarb(8)
  148. vz = xcarb(9)
  149. XCARB(7)=XCARB(ICARA-2)
  150. XCARB(8)=XCARB(ICARA-1)
  151. XCARB(9)=XCARB(ICARA)
  152. NTTRAV = icara - 9 - idim
  153. do ic =10,icara - idim
  154. ttrav(ic - 9) = xcarb(ic)
  155. enddo
  156. XCARB(10)=VX
  157. XCARB(11)=VY
  158. XCARB(12)=VZ
  159. do ic = 1,nttrav
  160. xcarb(12+ic) = ttrav(ic)
  161. enddo
  162. *
  163. ELSE IF (IDIM.EQ.2.and.ncarr.ge.3) THEN
  164. C poutre 2D
  165. C distinction entre poutre bernouilli et poutre timo en ce qui
  166. C concerne le defaut pour les sections reduites de l'effort tranchant
  167. SD=XCARB(1)
  168. SREDY=XCARB(3)
  169. IF(SREDY.EQ.0) XCARB(3)=SD
  170. ENDIF
  171.  
  172. *
  173. ELSE IF(MFRbi.EQ.13)THEN
  174. NTTRAV = icara - idim - 3
  175. DO 1111 IC=4,icara - idim
  176. TTRAV(IC-3)=XCARB(IC)
  177. 1111 continue
  178. IF(IDIM.EQ.2)THEN
  179. XCARB(4)=XCARB(ICARA-1)
  180. XCARB(5)=XCARB(ICARA)
  181. DO 1112 IC=1,NTTRAV
  182. XCARB(IC+5)=TTRAV(IC)
  183. 1112 continue
  184. ELSE IF(IDIM.EQ.3)THEN
  185. XCARB(4)=XCARB(ICARA-2)
  186. XCARB(5)=XCARB(ICARA-1)
  187. XCARB(6)=XCARB(ICARA)
  188. DO 1113 IC=1,NTTRAV
  189. XCARB(IC+6)=TTRAV(IC)
  190. 1113 continue
  191. ENDIF
  192. ENDIF
  193.  
  194. *
  195. * cas des poutres en formulation section
  196. *
  197. IF ((MFRbi.EQ.7.OR.MFRbi.EQ.13).AND.
  198. 1 CMATE.EQ.'SECTION') THEN
  199. *
  200. * >>>>>>>>>> cas des materiaux elastiques isotropes
  201. * ou unidirectionnels
  202. *
  203. ELSE IF(MATE.EQ.1.OR.MATE.EQ.4) THEN
  204. IF(INPLAS.EQ. 9.OR.INPLAS.EQ.28.OR.INPLAS.EQ.36.OR.
  205. & INPLAS.EQ.42.OR.INPLAS.EQ.66.OR.INPLAS.EQ.74.OR.
  206. & INPLAS.EQ.65.OR.INPLAS.EQ.106.OR.
  207. & INPLAS.EQ.107.OR.INPLAS.EQ.108.OR.
  208. & INPLAS.EQ.127.OR.INPLAS.EQ.128.OR.
  209. & INPLAS.LT.0) THEN
  210. *
  211. * pour les modeles beton et ubiquitous
  212. * et ceux dont on ne remodifie pas l'ordre
  213.  
  214.  
  215. ELSE
  216. *
  217. XLO=.TRUE.
  218. IF(MELE.GE.108.AND.MELE.LE.110) XLO=.FALSE.
  219. IF(MFR.EQ.33.AND.MATE.NE.1) XLO=.FALSE.
  220. IF(MFR.EQ.57.OR.MFR.EQ.59) XLO=.FALSE.
  221. *
  222. * on saute des elements n'ayant pas ALPH et RHO
  223. *
  224. IF(XLO) THEN
  225. * pour les autres modeles :
  226. * on a les noms : e,nu,puis le reste des obligatoires
  227. * puis les facultatives qui se terminent par rho et alph
  228. * d'apres un rangement dans idmatr
  229. * dans le remplissage de xmat, on veut e,nu,rho,alph
  230. * puis la suite. d'ou ce qui suit ....
  231. * am 9/11/93 a reprendre !!
  232. * am 28/7/95 le commentaire ci dessus est FAUX si l'on a des
  233. * proprietes facultatives en plus de rho et alph
  234. * car dans ce cas les facultatives COMMENCENT par
  235. * rho et alph. a reprendre !!!!!!!!
  236. *
  237. DO 1106 IC=1,NMATT
  238. IF ((MFRbi.EQ.1.OR.MFRbi.EQ.3.OR.MFRbi.EQ.31
  239. + .OR.MFRbi.EQ.33).AND.IFOUR.EQ.-2) THEN
  240. IF(IC.LE.2.OR.IC.EQ.NMATT) JC=IC
  241. IF(IC.GT.2.AND.IC.LT.NMATT-2) JC=IC+2
  242. IF(IC.EQ.NMATT-2) JC=3
  243. IF(IC.EQ.NMATT-1) JC=4
  244. ELSEIF(CMATEE.EQ.'IMPELAST')THEN
  245. * kich impedance a completer selon inplas. par defaut :
  246. IF(IC.EQ.1) JC = IC
  247. IF(IC.GE.2.AND.IC.LT.NMATT-2) JC = IC + 3
  248. IF(IC.GE.NMATT-2) JC = IC-NMATT+4
  249. ELSE
  250. IF(IC.LE.2) JC=IC
  251. IF(IC.GT.2.AND.IC.LT.NMATT-1) JC=IC+2
  252. IF(IC.EQ.NMATT-1) JC=3
  253. IF(IC.EQ.NMATT) JC=4
  254. ENDIF
  255. XMAT(jc) = VALMAT(ic)
  256. xmat0(jc) = valma0(ic)
  257. * le tableau tymat de WRK54 est relatif a XMAT et xma0
  258. tymat(jc) = tyval(ic)
  259. c PRINT *,'XMAT(',JC,')=',XMAT(JC),tymat(jc)
  260. 1106 continue
  261. *
  262. if (cmatee.eq.'IMPELAST'.and.inatuu.ne.161) then
  263. * necessaire pour hookis kich
  264. valmat(2) = xmat(2)
  265. valmat(NMATT-2) = xmat(NMATT-2)
  266. endif
  267. * rearrangement pour certaines lois cas elastique isotrope
  268. *
  269. IF (INPLAS.EQ.7) THEN
  270. * chaboche 1
  271. ELSE IF (INPLAS.EQ.2) THEN
  272. IF (XMAT(6).NE.0.D0) THEN
  273. INPLAS=27
  274. XMAT(5)=XMAT(6)
  275. xmat0(5)=xmat0(6)
  276. ENDIF
  277. ELSE IF (INPLAS.EQ.12) THEN
  278. * chaboche 2
  279. ELSE IF (INPLAS.EQ.14) THEN
  280. IF(XMAT(8).NE.0.D0 .OR. XMAT(9).NE.0.D0) THEN
  281. INPLAS=18
  282. XMAT(5)=XMAT(8)
  283. XMAT(6)=XMAT(9)
  284. xmat0(5)=xmat0(8)
  285. xmat0(6)=xmat0(9)
  286. ENDIF
  287. ELSE IF(INPLAS.EQ.64) THEN
  288. C gurson2
  289. XSRMA=XMAT(3)
  290. XMAT(3)=XMAT(17)
  291. XMAT(17)=XMAT(4)
  292. XMAT(4)=XSRMA
  293. ENDIF
  294. ENDIF
  295.  
  296. ENDIF
  297. *
  298. *-----------------------------------------------------------
  299. * rearrangement pour certaines formulations
  300. *-----------------------------------------------------------
  301. * cas milieu poreux
  302. *
  303. IF (MFRBI.EQ.33.AND.MATE.EQ.1) THEN
  304. ICAS=1
  305. CALL COMEFF(IQMOD,IWRK52,IWRK53,IWRK54,IECOU,ICAS,IRETOU)
  306. IF (iretou.NE.0) RETURN
  307. ENDIF
  308. *
  309. * cas des materiaux unidirectionnels
  310. * en plasticite
  311. *
  312. * ce qui suit est limité au coq2 et au dst
  313. *
  314. * on met v1x et v1y à la place de rho et alph
  315. * on met nu à 0. et on se decale ( on ignore les axes )
  316. *
  317. * dans le cas des coq2, il faut aller chercher les contraintes
  318. * dans la direction ad-hoc. inutile pour le dst.
  319. * on se limite au cas axisymetrique ?
  320. *
  321. IF (MATE.EQ.4.AND.INPLAS.NE.0) THEN
  322. XMAT(3)=XMAT(2)
  323. xmat0(3)=xmat0(2)
  324. XMAT(2)=0.D0
  325. xmat0(2)=0.D0
  326. DO 1995 IC=4,NMATT-1
  327. XMAT(IC) = XMAT(IC+1)
  328. xmat0(IC) = xmat0(IC+1)
  329. 1995 CONTINUE
  330. *
  331. * coq2 : on change les contraintes de repere
  332. * les variables internes sont dans le repere unidirectionnel
  333. *
  334. IF (MELE.EQ.44) THEN
  335. DO 1996 I=1,NSTRS
  336. BID(I)=SIG0(I)
  337. BID2(I)=DSIGT(I)
  338. 1996 CONTINUE
  339. *
  340. ELSEIF(LUNI1)THEN
  341. V1X=TXR(1,1)*XMAT(3)+TXR(1,2)*XMAT(4)
  342. V1Y=TXR(2,1)*XMAT(3)+TXR(2,2)*XMAT(4)
  343. XMAT(3)=V1X
  344. XMAT(4)=V1Y
  345. * heu il faudrait peut etre revoir TXR . kich
  346. V1X=TXR(1,1)*xmat0(3)+TXR(1,2)*xmat0(4)
  347. V1Y=TXR(2,1)*xmat0(3)+TXR(2,2)*xmat0(4)
  348. xmat0(3)=V1X
  349. xmat0(4)=V1Y
  350. ELSEIF(LUNI2)THEN
  351. *
  352. ELSE
  353. RETURN
  354. ENDIF
  355. ENDIF
  356. *
  357. ENDIF
  358. *
  359.  
  360. IF (MFRbi.EQ.27.OR.MFRbi.EQ.49) THEN
  361. *
  362. * on cherche la section de l'element ib
  363. *
  364. SECT = xcarb(1)
  365. if (cmatee.eq.'IMPELAST'.and.inatuu.ne.161) then
  366. SECT = 1.D0
  367. xcarb(1) = 1.D0
  368. endif
  369. *
  370. * prise en compte de l'epaisseur et de l'excentrement
  371. * dans le cas des coques minces avec ou sans cisaillement
  372. * transverse
  373. *
  374. ELSE IF (MFRbi.EQ.3.OR.MFRbi.EQ.9) THEN
  375. IF (CMATE.EQ.'ISOTROPE' .OR. CMATE.EQ.'ORTHOTRO' .OR.
  376. 1 CMATE.EQ.'UNIDIREC')
  377. 2 EPAIST = xcarb(1)
  378. ENDIF
  379.  
  380. IF (INPLAS.EQ.29 .OR. INPLAS.EQ.26 .OR. INPLAS.EQ.142) THEN
  381. *
  382. * pour les materiaux endommageables de lemaitre traitement special
  383. * car ils peuvent dependre de la temperature
  384. *
  385. NTABO1 = nmatt
  386. NTABO2 = nmatt+2*ncourb
  387. NTABq1 = 0
  388. NTABq2 = 0
  389. if (wr10.eq.0) then
  390. * write (6,*) 'ini wr10',ntabo1,ntabo2
  391. SEGINI WR10
  392. endif
  393. DO 2200 JC=1,NMATT
  394. IF (TYMAT(JC)(1:8).EQ.'REAL*8 ') THEN
  395. NTABq1=NTABq1+1
  396. NTABq2=NTABq2+1
  397. if (ntabq1.gt.iablo1(/1)) ntabo1=ntabq1+64
  398. if (ntabq2.gt.tablo2(/1)) ntabo2=ntabq2+64
  399. if (ntabo1.gt.iablo1(/1).or.
  400. > ntabo2.gt.tablo2(/1)) then
  401. * write (6,*) 'adj 1 wr10',ntabo1,ntabo2
  402. SEGADJ WR10
  403. endif
  404. IABLO1(NTABq1)=1
  405. TABLO2(NTABq2)=XMAT(JC)
  406. ELSE IF (TYMAT(JC)(9:16).EQ.'EVOLUTIO') THEN
  407. xmatjc = xmat(jc)
  408. ncoor=ncourb
  409. CALL KSISI1(xmatjc,JC,WRK2,Nccor,kerre7)
  410. IF (kerre7.NE.0) THEN
  411. KERRE = kerre7
  412. IRETOU = 1
  413. RETURN
  414. ENDIF
  415. ncourb=nccor
  416. NTABq1=NTABq1+1
  417. NTABq=NTABq2
  418. NTABq2=NTABq2+(2*NCOURB)
  419. if (ntabq1.gt.iablo1(/1)) ntabo1=ntabq1+64
  420. if (ntabq2.gt.tablo2(/1)) ntabo2=ntabq2+64
  421. if (ntabo1.gt.iablo1(/1).or.
  422. > ntabo2.gt.tablo2(/1)) then
  423. * write (6,*) 'adj 2 wr10',ntabo1,ntabo2
  424. SEGADJ WR10
  425. endif
  426. IABLO1(NTABq1)=2*NCOURB
  427. DO 2050 JCC=1,NCOURB
  428. TABLO2(NTABq+(2*JCC-1))=TRAC(2*JCC-1)
  429. TABLO2(NTABq+(2*JCC))=TRAC(2*JCC)
  430. 2050 continue
  431. ELSE IF (TYMAT(JC)(9:16).EQ.'NUAGE ') THEN
  432. NTABO3 = 0
  433. NTABO4 = 0
  434. SEGINI WR11
  435. xmatjc = xmat(jc)
  436. CALL XNUAG1(xmatjc,JC,WR11,NTABO3,NTABO4,kerre1)
  437. IF (kerre1.NE.0) THEN
  438. KERRE = kerre1
  439. SEGSUP WR10
  440. SEGSUP WR11
  441. KERR1=2
  442. IRETOU = 1
  443. RETURN
  444. ENDIF
  445. * segadj wr11
  446. NTABq=NTABq1
  447. NTABqO=NTABq2
  448. NTABq1=NTABq1+NTABO3+1
  449. NTABq2=NTABq2+NTABO4
  450. if (ntabq1.gt.iablo1(/1)) ntabo1=ntabq1+64
  451. if (ntabq2.gt.tablo2(/1)) ntabo2=ntabq2+64
  452. if (ntabo1.gt.iablo1(/1).or.
  453. > ntabo2.gt.tablo2(/1)) then
  454. * write (6,*) 'adj 3 wr10',ntabo1,ntabo2
  455. SEGADJ WR10
  456. endif
  457. IABLO1(NTABq+1)=NTABO3
  458. DO 2075 JCC=1,NTABO3
  459. 2075 iablo1(ntabq+1+jcc)=iablo3(jcc)
  460. DO 2125 JCC=1,NTABO4
  461. 2125 tablo2(ntabqo+jcc)=tablo4(jcc)
  462. SEGSUP WR11
  463. ENDIF
  464. 2200 continue
  465. ENDIF
  466. if (wr10.ne.0) then
  467. ntabo1=ntabq1
  468. ntabo2=ntabq2
  469. ** write (6,*) 'comara nmatt ntabo1 ntabo2',nmatt,ntabo1,ntabo2
  470. if (ntabo1.ne.iablo1(/1).or.
  471. > ntabo2.ne.tablo2(/1)) then
  472. * write (6,*) 'adj 4 wr10 ',ntabo1,ntabo2
  473. SEGADJ WR10
  474. endif
  475. endif
  476.  
  477.  
  478.  
  479.  
  480. *
  481. * >>>>>>>>>> fin du traitement du materiau endommageables de lemaitre
  482. **
  483. return
  484.  
  485. C========================
  486. C = AUTRES FORMULATIONS =
  487. C========================
  488. 20 continue
  489. * if (formod(1).ne.'METALLURGIE') goto 130
  490. * return
  491.  
  492. 130 continue
  493.  
  494. RETURN
  495. END
  496.  
  497.  
  498.  
  499.  
  500.  
  501.  
  502.  

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