Télécharger adetat.eso

Retour à la liste

Numérotation des lignes :

adetat
  1. C ADETAT SOURCE PASCAL 20/12/03 21:15:01 10801
  2.  
  3. subroutine adetat
  4.  
  5. implicit real*8(a-h,o-Z)
  6. implicit integer (i-n)
  7. *
  8. * on ne travaille que sur les formulations mecanique et poreux,
  9. * thermique, diffusion (, electrostatique) et LIAISON (kich)
  10. *
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMCHAML
  15. -INC SMCHPOI
  16. -INC SMMODEL
  17. -INC SMCHARG
  18. -INC SMTABLE
  19. segment limode(0)
  20. parameter (nnonom=16, nnoind=8, nnofor=10)
  21. character*22 indic(nnoind)
  22. dimension ilo(nnoind)
  23. character*16 mformu(nnofor)
  24. character*8 ctyp,mtyp,chai1
  25. logical ibo
  26. character*4 init(1),nomc,nonom(nnonom)
  27. data nonom/'MECA','DIMP','TIMP','TERA','TECO',
  28. $ 'Q ','DEFI','REAC','CIMP','UIMP',
  29. $ 'FORC','MODE','MATE','BLOD','BLOM','BLOT'/
  30. data init/'NOUV'/
  31. data indic /'DEPLACEMENTS ','CONTRAINTES ',
  32. & 'TEMPERATURES ','VARIABLES_INTERNES ',
  33. & 'DEFINELA ','PROPORTIONS_PHASE ',
  34. & 'CONCENTRATIONS ','POTENTIELS_ELECTRIQUES'/
  35. data ilo / 12, 11, 12, 18, 8, 17, 14, 22 /
  36. data mformu /'MECANIQUE ','POREUX ',
  37. & 'LIAISON ','DIFFUSION ',
  38. & 'ELECTROSTATIQUE ','THERMIQUE ',
  39. & 'CHARGEMENT ','METALLURGIE ',
  40. & 'CHANGEMENT_PHASE','MELANGE '/
  41.  
  42. call lirmot(init,1,initia,0)
  43. call LIROBJ('MMODEL ',IPMODL,1,iretou)
  44. call ACTOBJ('MMODEL ',IPMODL,1)
  45. IF(IERR.NE.0) RETURN
  46.  
  47. C Extension du MMODEL en cas de modele de MELANGE
  48. CALL MODETE(IPMODL,MMODEL,IMELAN)
  49.  
  50. if(initia.eq.0)then
  51. mchelm=0
  52. call LIROBJ('MCHAML ',mchelm,1,iretou)
  53. CALL ACTOBJ('MCHAML ',mchelm,1)
  54. if (ierr.ne.0) return
  55. segini,mchel2=mchelm
  56. n1=mchel2.ichaml(/1)
  57. n3=mchel2.infche(/2)
  58. l1=16
  59. segadj,mchel2
  60. else
  61. n1=0
  62. n3=6
  63. l1=16
  64. segini mchel2
  65. mchel2.ifoche=ifour
  66. endif
  67. mchel2.TITCHE='cree par adetat'
  68.  
  69.  
  70. n1io =n1
  71. NSOUS=MMODEL.KMODEL(/1)
  72. MMODE1=MMODEL
  73.  
  74. N1 =NSOUS
  75. NZON=0
  76.  
  77. * On compte combien de formulations incluses dans mformu
  78. DO 1119 I=1,NSOUS
  79. IMODEL=MMODE1.KMODEL(I)
  80. NFOR =FORMOD(/2)
  81. IF (NFOR.EQ.1) THEN
  82. CALL PLACE(mformu,nnofor,iplac,FORMOD(1))
  83. if (iplac.EQ.0) GOTO 1119
  84. ELSEIF(NFOR.EQ.2) THEN
  85. CALL PLACE(mformu,2,iplac,FORMOD(1))
  86. if (iplac.EQ.0) GOTO 1119
  87. CALL PLACE(mformu,2,iplac,FORMOD(2))
  88. if (iplac.EQ.0) GOTO 1119
  89. ELSE
  90. GOTO 1119
  91. ENDIF
  92. * on vient ici pour prendre les sous modeles
  93. NZON=NZON+1
  94. 1119 CONTINUE
  95.  
  96. *on recommence
  97. mmodel=mmode1
  98. if (nzon.ne.nsous .and. nzon.ne.0) then
  99. n1=nzon
  100. nzon=0
  101. segini mmodel
  102. DO 1129 I=1,NSOUS
  103. IMODEL=MMODE1.KMODEL(I)
  104. NFOR=FORMOD(/2)
  105. IF(NFOR.EQ.1) THEN
  106. CALL PLACE(mformu,nnofor,iplac,FORMOD(1))
  107. if (iplac.EQ.0) GOTO 1129
  108. ELSE IF(NFOR.EQ.2) THEN
  109. CALL PLACE(mformu,2,iplac,FORMOD(1))
  110. if (iplac.EQ.0) GOTO 1129
  111. CALL PLACE(mformu,2,iplac,FORMOD(2))
  112. if (iplac.EQ.0) GOTO 1129
  113. ELSE
  114. GO TO 1129
  115. ENDIF
  116. * on vient ici pour prendre les sous modeles
  117. NZON=NZON+1
  118. KMODEL(NZON)=IMODEL
  119. 1129 continue
  120. endif
  121. NSOUS=n1
  122. if(ierr.ne.0) return
  123. n1 = n1io
  124.  
  125.  
  126.  
  127. do 1 i = 1, 1000
  128. ctyp=' '
  129. CALL QUETYP(CTYP,0,IRETOU)
  130. * write(6,*) ' iretou ctyp' , iretou,ctyp
  131. if(iretou.eq.0) go to 2
  132. if(ctyp.eq.'FLOTTANT'.or.ctyp.eq.'ENTIER') then
  133. call lirree(xva,1,iret)
  134. ctyp='FLOTTANT'
  135. call lircha(nomc,1,iretou)
  136. elseif(ctyp.eq.'MOT' ) then
  137. call lircha(nomc,1,iretou)
  138. call lirree(xva,1,iret)
  139. ctyp='FLOTTANT'
  140. else
  141. call LIROBJ(ctyp,ipo,1,iretou)
  142. call actobj(ctyp,ipo,1)
  143. endif
  144. if(ierr.ne.0) return
  145.  
  146.  
  147. if(ctyp.eq.'CHPOINT') then
  148. CALL ACTOBJ('CHPOINT ',IPO,1)
  149. CALL CHAME1(0,MMODEL,IPO,' ',Ipche2,5)
  150. IF (IERR.NE.0) RETURN
  151. ipo=ipche2
  152.  
  153. elseif(ctyp.eq.'FLOTTANT') then
  154. call ecrcha('STRESSES')
  155. call ecrree(xva)
  156. call ecrcha(nomc)
  157. call ECROBJ('MMODEL ',mmodel)
  158. call ecrcha('CHML')
  159. call manuel
  160. if(ierr.ne.0) return
  161. call LIROBJ('MCHAML ',ipo,1,iretou)
  162. call ACTOBJ('MCHAML ',ipo,1)
  163.  
  164. elseif(ctyp.eq.'CHARGEME') then
  165. mcharg=ipo
  166. call lirree(xva,1,iret)
  167. if(ierr.ne.0) then
  168. return
  169. endif
  170. segact mcharg
  171. ika=0
  172. do 10 k=1,kcharg(/1)
  173. nomc=chanom(k)
  174. do ka=1,nnonom
  175. if( nomc.eq.nonom(ka) ) go to 10
  176. enddo
  177. * write(6,*) ' adetat nomc ', nomc
  178. ika=ika+1
  179. call ecrcha(nomc)
  180. call ecrree (xva)
  181. call ECROBJ('CHARGEME',mcharg)
  182. call tire
  183. segact mcharg
  184. call quetyp(ctyp,1,iretou)
  185. if(ierr.ne.0) return
  186. call LIROBJ(ctyp,ipa,1,iretou)
  187. ipche2=ipa
  188. if(ctyp.eq.'CHPOINT ') then
  189. CALL ACTOBJ('CHPOINT ',IPA,1)
  190. CALL CHAME1(0,MMODEL,IPA,' ',Ipche2,5)
  191. IF (IERR.NE.0) RETURN
  192. elseif (ctyp.eq.'MCHAML') then
  193. *
  194. * AM 21/5/08
  195. * SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE
  196. * SI CE N'EST PAS POSSIBLE, ON VA EN 10
  197. *
  198. CALL ACTOBJ('MCHAML ',IPA,1)
  199. CALL REDUAF(IPA,MMODEL,IPA2,0,IRET,KERRE)
  200. IF(IRET.EQ.0) THEN
  201. GO TO 10
  202. ENDIF
  203. *
  204. CALL CHASUP(MMODEL,IPA2,IPche2,IRET,5)
  205. else
  206. C SP 11/06/20
  207. C Si autre type (MMODEL par ex.), on itere :
  208. C write(6,*) ' Objet tire du charg. de type', ctyp
  209. GOTO 10
  210. endif
  211. mchel3=ipche2
  212. n13= mchel3.ichaml(/1)
  213. n33= mchel3.infche(/2)
  214. iy=n1
  215. n1 = n1 + n13
  216. n3= max(n3,n33)
  217. segadj mchel2
  218. do kk=1,n13
  219. mchel2.conche(iy+kk)=mchel3.conche(kk)
  220. mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  221. mchel2.imache(iy+kk)=mchel3.imache(kk)
  222. do jk=1,n33
  223. mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  224. enddo
  225. enddo
  226. 10 continue
  227. go to 1
  228.  
  229. elseif(ctyp.eq.'TABLE') then
  230. ika=0
  231. mtable=ipo
  232. segact mtable
  233. ika=0
  234. do 11 k=1,nnoind
  235. mtyp=' '
  236. call ACCTAB(mtable,'MOT ',IJ,XJ,indic(k)(1:ilo(k)),ibo,IU,
  237. $ MTYP,IK,XK,CHAI1,IBO,IPA)
  238. segact mtable
  239. if(MTYP.EQ.' ') go to 11
  240. if(MTYP.eq.'CHPOINT ') then
  241. CALL ACTOBJ('CHPOINT ',IPA,1)
  242. CALL CHAME1(0,MMODEL,IPA,' ',Ipche2,5)
  243. IF (IERR.NE.0) RETURN
  244. elseif(mtyp.eq.'MCHAML' ) then
  245. *
  246. * AM 21/5/08
  247. * SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE
  248. * SI CE N'EST PAS POSSIBLE, ON VA EN 11
  249. *
  250. CALL ACTOBJ('MCHAML ',IPA,1)
  251. CALL REDUAF(IPA,MMODEL,IPA2,0,IRET,KERRE)
  252. IF(IRET.EQ.0) THEN
  253. GO TO 11
  254. ENDIF
  255. *
  256. CALL CHASUP(MMODEL,IPA2,IPche2,IRET,5)
  257. else
  258. go to 11
  259. endif
  260. mchel3=ipche2
  261. n13= mchel3.ichaml(/1)
  262. n33= mchel3.infche(/2)
  263. iy=n1
  264. n1 = n1 + n13
  265. n3= max(n3,n33)
  266. segadj mchel2
  267. do kk=1,n13
  268. mchel2.conche(iy+kk)=mchel3.conche(kk)
  269. mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  270. mchel2.imache(iy+kk)=mchel3.imache(kk)
  271. do jk=1,n33
  272. mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  273. enddo
  274. enddo
  275. 11 continue
  276. go to 1
  277. endif
  278. mchel3=ipo
  279. * PV
  280. CALL CHASUP(MMODEL,mchel3,mchpv,IRET,5)
  281. IF (IRET.NE.0) CALL ERREUR(IRET)
  282. if (ierr.ne.0) return
  283. mchel3=mchpv
  284. n13= mchel3.ichaml(/1)
  285. n33= mchel3.infche(/2)
  286. iy=n1
  287. n1 = n1 + n13
  288. n3= max(n3,n33)
  289. segadj mchel2
  290. do kk=1,n13
  291. mchel2.conche(iy+kk)=mchel3.conche(kk)
  292. mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  293. mchel2.imache(iy+kk)=mchel3.imache(kk)
  294. do jk=1,n33
  295. mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  296. enddo
  297. enddo
  298. 1 continue
  299. 2 continue
  300.  
  301. if( n1.eq.0) then
  302. * call erreur (19)
  303. call actobj('MCHAML ',mchel2,1)
  304. call ECROBJ('MCHAML ',mchel2)
  305. else
  306. * on va essayer de regrouper les supports de chamelem car plusieurs
  307. * operateurs partent du principes que si un modele a n sous-zones le
  308. * chamelem doit avoir le meme nombre de sous zones
  309. iprio=5
  310. * call zpchel (mchel2,1)
  311. call confor(mchel2,mchel1, mmodel,iprio)
  312. * call zpchel( mchel1,1)
  313. call actobj('MCHAML ',mchel1,1)
  314. call ECROBJ('MCHAML ',mchel1)
  315. endif
  316.  
  317. end
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  

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