Télécharger adetat.eso

Retour à la liste

Numérotation des lignes :

  1. C ADETAT SOURCE MB234859 16/09/16 21:15:01 9091
  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=7)
  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' /
  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. 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. SEGDES IMODEL
  162. 1129 continue
  163. 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. if(ctyp.eq.'CHPOINT') then
  187. CALL CHAME1(0,MMODEL,IPO,' ',Ipche2,5)
  188. IF (IERR.NE.0) RETURN
  189. ipo=ipche2
  190. elseif(ctyp.eq.'FLOTTANT') then
  191. call ecrcha('STRESSES')
  192. call ecrree(xva)
  193. call ecrcha(nomc)
  194. call ecrobj('MMODEL',mmodel)
  195. call ecrcha('CHML')
  196. call manuel
  197. if(ierr.ne.0) return
  198. call lirobj('MCHAML',ipo,1,iretou)
  199. elseif(ctyp.eq.'CHARGEME') then
  200. mcharg=ipo
  201. call lirree(xva,1,iret)
  202. if(ierr.ne.0) then
  203. return
  204. endif
  205. segact mcharg
  206. ika=0
  207. do 10 k=1,kcharg(/1)
  208. nomc=chanom(k)
  209. do ka=1,nnonom
  210. if( nomc.eq.nonom(ka) ) go to 10
  211. enddo
  212. * write(6,*) ' adetat nomc ', nomc
  213. ika=ika+1
  214. call ecrcha(nomc)
  215. call ecrree (xva)
  216. call ecrobj ('CHARGEME',mcharg)
  217. call tire
  218. segact mcharg
  219. call quetyp(ctyp,1,iretou)
  220. if(ierr.ne.0) return
  221. call lirobj(ctyp,ipa,1,iretou)
  222. ipche2=ipa
  223. if(ctyp.eq.'CHPOINT') then
  224. CALL CHAME1(0,MMODEL,IPA,' ',Ipche2,5)
  225. IF (IERR.NE.0) RETURN
  226. elseif (ctyp.eq.'MCHAML') then
  227. *
  228. * AM 21/5/08
  229. * SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE
  230. * SI CE N'EST PAS POSSIBLE, ON VA EN 10
  231. *
  232. CALL REDUAF(IPA,MMODEL,IPA2,0,IRET,KERRE)
  233. IF(IRET.EQ.0) THEN
  234. GO TO 10
  235. ENDIF
  236. *
  237. CALL CHASUP(MMODEL,IPA2,IPche2,IRET,5)
  238. endif
  239. mchel3=ipche2
  240. segact mchel3
  241. n13= mchel3.ichaml(/1)
  242. n33= mchel3.infche(/2)
  243. iy=n1
  244. n1 = n1 + n13
  245. n3= max(n3,n33)
  246. segadj mchel2
  247. do kk=1,n13
  248. mchel2.conche(iy+kk)=mchel3.conche(kk)
  249. mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  250. mchel2.imache(iy+kk)=mchel3.imache(kk)
  251. do jk=1,n33
  252. mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  253. enddo
  254. enddo
  255. 10 continue
  256. segdes mcharg
  257. go to 1
  258. elseif(ctyp.eq.'TABLE') then
  259. ika=0
  260. mtable=ipo
  261. segact mtable
  262. ika=0
  263. do 11 k=1,nnoind
  264. mtyp=' '
  265. call ACCTAB(mtable,'MOT ',IJ,XJ,indic(k)(1:ilo(k)),ibo,IU,
  266. $ MTYP,IK,XK,CHAI1,IBO,IPA)
  267. segact mtable
  268. if(MTYP.EQ.' ') go to 11
  269. if(MTYP.eq.'CHPOINT ') then
  270. CALL CHAME1(0,MMODEL,IPA,' ',Ipche2,5)
  271. IF (IERR.NE.0) RETURN
  272. elseif(mtyp.eq.'MCHAML' ) then
  273. *
  274. * AM 21/5/08
  275. * SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE
  276. * SI CE N'EST PAS POSSIBLE, ON VA EN 11
  277. *
  278. CALL REDUAF(IPA,MMODEL,IPA2,0,IRET,KERRE)
  279. IF(IRET.EQ.0) THEN
  280. GO TO 11
  281. ENDIF
  282. *
  283. CALL CHASUP(MMODEL,IPA2,IPche2,IRET,5)
  284. else
  285. go to 11
  286. endif
  287. mchel3=ipche2
  288. segact mchel3
  289. n13= mchel3.ichaml(/1)
  290. n33= mchel3.infche(/2)
  291. iy=n1
  292. n1 = n1 + n13
  293. n3= max(n3,n33)
  294. segadj mchel2
  295. do kk=1,n13
  296. mchel2.conche(iy+kk)=mchel3.conche(kk)
  297. mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  298. mchel2.imache(iy+kk)=mchel3.imache(kk)
  299. do jk=1,n33
  300. mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  301. enddo
  302. enddo
  303. 11 continue
  304. segdes mtable
  305. go to 1
  306. endif
  307. mchel3=ipo
  308. * PV
  309. CALL CHASUP(MMODEL,mchel3,mchpv,IRET,5)
  310. IF (IRET.NE.0) CALL ERREUR(IRET)
  311. if (ierr.ne.0) return
  312. mchel3=mchpv
  313. segact mchel3
  314. n13= mchel3.ichaml(/1)
  315. n33= mchel3.infche(/2)
  316. iy=n1
  317. n1 = n1 + n13
  318. n3= max(n3,n33)
  319. segadj mchel2
  320. do kk=1,n13
  321. mchel2.conche(iy+kk)=mchel3.conche(kk)
  322. mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  323. mchel2.imache(iy+kk)=mchel3.imache(kk)
  324. do jk=1,n33
  325. mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  326. enddo
  327. enddo
  328. 1 continue
  329. 2 continue
  330.  
  331. if( n1.eq.0) then
  332. * call erreur (19)
  333. call ecrobj('MCHAML',mchel2)
  334. else
  335. * on va essayer de regrouper les supports de chamelem car plusieurs
  336. * opérateurs partent du principes que si un modèle à n sous -zones le
  337. * chamelem doit avoir le meme nombre de sous zones
  338. iprio=5
  339. * call zpchel (mchel2,1)
  340. call confor(mchel2,mchel1, mmodel,iprio)
  341. * call zpchel( mchel1,1)
  342. call ecrobj('MCHAML',mchel1)
  343. endif
  344.  
  345. return
  346. end
  347.  
  348.  
  349.  
  350.  

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