Télécharger adetat.eso

Retour à la liste

Numérotation des lignes :

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

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