Télécharger comara.eso

Retour à la liste

Numérotation des lignes :

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

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