Télécharger evtem1.eso

Retour à la liste

Numérotation des lignes :

  1. C EVTEM1 SOURCE JC220346 18/12/04 21:15:23 9991
  2. subroutine EVTEM1(icoul)
  3. implicit integer(i-n)
  4. implicit real*8(a-h,o-z)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC CCNOYAU
  9. -INC SMCHAML
  10. -INC SMCHPOI
  11. -INC SMTABLE
  12. -INC SMLREEL
  13. -INC SMEVOLL
  14. -INC SMELEME
  15. logical login
  16. character*8 typobj
  17. character*18 charin,chalu
  18. character*1 charre
  19. character*4 compo,noco
  20. character*(LONOM) nompoi
  21. call lirobj ('TABLE ',mtable,1,iretou)
  22. if(ierr.ne.0) return
  23. ilo=0
  24. call lircha(chalu,1,ilo)
  25. TYPOBJ='TABLE'
  26. charin='TEMPS'
  27. segact mtable
  28. call acctab(mtable,'MOT',ivalin,xvalin,charin(1:5),login,iobi,
  29. $ TYPOBJ,ivalin,xvalin,charre,login,mtab1)
  30. if( ierr.ne.0) return
  31. segact mtable
  32. call acctab(mtable,'MOT',ivalin,xvalin,chalu(1:ilo),login,iobi,
  33. $ TYPOBJ,ivalin,xvalin,charre,login,mtab2)
  34. if( ierr.ne.0) return
  35. compo=' '
  36. call lircha (compo,0,ilp)
  37. segact mtab1,mtab2
  38. typobj=mtab2.mtabtv(1)
  39. if(typobj.eq.'CHPOINT ') then
  40. call lirobj('POINT' , IP1,1,iretou)
  41. call quenom(nompoi)
  42. if(ierr.ne.0) then
  43. moterr(1:8)='TABLE'
  44. segdes mtab1,mtab2
  45. return
  46. endif
  47. jg = mtab1.mlotab
  48. if(mtab2.mlotab.ne.jg) then
  49. segdes mtab1,mtab2
  50. call erreur ( 1015 )
  51. return
  52. endif
  53. segini mlree1,mlree2
  54. do 10 ia=1,mtab1.mlotab
  55.  
  56. mlree1.prog(ia)= mtab1.rmtabv(ia)
  57. mchpoi=mtab2.mtabiv(ia)
  58. segact mchpoi
  59. if( ipchp(/1).eq.0.and.ia.eq.1) then
  60. mlree2.prog(ia)=0.
  61. segdes mchpoi
  62. go to 10
  63. endif
  64. do 11 isou=1,ipchp(/1)
  65. msoupo= ipchp(isou)
  66. segact msoupo
  67. meleme=igeoc
  68. segact meleme
  69. noco=nocomp(1)
  70. icomp=1
  71. do 12 iel=1,num(/2)
  72. if(num(1,iel).eq.ip1) then
  73. if(ilp.eq.0.and.nocomp(/2).ne.1) then
  74. MOTERR(1:8)='chpoint'
  75. INTERR(1)=NOCOMP(/2)
  76. call erreur(761)
  77. segdes meleme,msoupo,mchpoi
  78. go to 100
  79. endif
  80. do 13 icomp=1,nocomp(/2)
  81. noco=nocomp(icomp)
  82. if(nocomp(icomp).eq.compo) goto 14
  83. 13 continue
  84.  
  85. MOTERR(1:4)=COMPO
  86. moterr(5:12)='CHPOINT'
  87. interr(1)=ip1
  88. call erreur(65)
  89. segdes meleme,msoupo,mchpoi
  90. go to 100
  91. 14 continue
  92. mpoval=ipoval
  93. segact mpoval
  94. noco=nocomp(icomp)
  95. mlree2.prog(ia)=vpocha(iel,icomp)
  96. segdes mpoval
  97. segdes meleme
  98. segdes mchpoi
  99. segdes msoupo
  100. go to 10
  101. endif
  102. 12 continue
  103. segdes meleme
  104. segdes msoupo
  105. 11 continue
  106. interr(1)=ip1
  107. moterr(1:)='CHPOINT'
  108. call erreur(64)
  109. segdes mchpoi
  110. go to 100
  111. 10 continue
  112.  
  113. segdes mlree1,mlree2
  114. N=1
  115.  
  116. segini mevoll
  117. ityevo='REEL'
  118. IEVTEX=chalu(1:ilo)//' '//noco//' fonction du temps du point '
  119. $ //nompoi
  120. segini kevoll
  121. ievoll(1)=kevoll
  122. iprogx=mlree1
  123. iprogy=mlree2
  124. numevx=icoul
  125. NUMEVY='REEL'
  126. NOMEVY=chalu(1:6) // ' '//noco
  127. NOMEVX='TEMPS'
  128. TYPX='LISTREEL'
  129. TYPY='LISTREEL'
  130. KEVTEX=chalu(1:ilo)//' fonction du temps du point '//nompoi
  131. 101 format (I6)
  132. segdes mevoll,kevoll
  133. call ecrobj('EVOLUTIO',mevoll)
  134. return
  135. elseif(typobj.eq.'MCHAML' )then
  136. call lirent ( izo,1,iretou)
  137. if(ierr.ne.0) return
  138. call lirent(iel,1,iretou)
  139. if(ierr.ne.0) return
  140. call lirent(iga,1,iretou)
  141. if(ierr.ne.0) return
  142. jg = mtab1.mlotab
  143. if(mtab2.mlotab.ne.jg) then
  144. segdes mtab1,mtab2
  145. call erreur ( 1015 )
  146. go to 100
  147. endif
  148. segini mlree1,mlree2
  149. do 20 ia = 1, mtab2.mlotab
  150. mlree1.prog(ia)= mtab1.rmtabv(ia)
  151. mchelm=mtab2.mtabiv(ia)
  152. segact mchelm
  153. if( ichaml(/1).lt.izo) then
  154. call erreur(279)
  155. segdes mchelm
  156. go to 100
  157. endif
  158. mchaml=ichaml(izo)
  159. meleme=imache(izo)
  160. segact mchaml,meleme
  161. icomp=1
  162. if(ilp.eq.0.and.nocomp(/2).ne.1) then
  163. MOTERR(1:8)='MCHAML'
  164. INTERR(1)=NOMCHE(/2)
  165. call erreur(761)
  166. segdes mchaml,mchelm,meleme
  167. go to 100
  168. endif
  169. if(num(/2).lt.iel) then
  170. call erreur(262)
  171. segdes mchelm,mchaml,meleme
  172. go to 100
  173. endif
  174. noco=nomche(1)
  175. icomp=1
  176. do 23 icomp=1,nomche(/2)
  177. noco=nomche(icomp)
  178. if(noco.eq.compo) goto 24
  179. 23 continue
  180. MOTERR(1:4)=COMPO
  181. moterr(5:12)='MCHAML'
  182. interr(1)=ip1
  183. call erreur(65)
  184. segdes mchelm,mchaml,meleme
  185. go to 100
  186. 24 continue
  187. melval=ielval(icomp)
  188. segact melval
  189. mlree2.prog(ia)=velche(min(velche(/1),iga),min(velche(/2),iel))
  190. segdes melval
  191. segdes mchaml,meleme
  192. segdes mchelm
  193. 20 continue
  194. endif
  195. N=1
  196. segini mevoll
  197. segini kevoll
  198. ityevo='REEL'
  199. if(typobj.eq.'CHPOINT ') then
  200. IEVTEX=chalu(1:ilo)//' '//noco//' fonction du temps du point '
  201. $ //nompoi
  202. elseif(typobj.eq.'MCHAML') then
  203. IEVTEX=chalu(1:ilo)//' '//noco//' zone '
  204. write(ievtex(ilo+12:ilo+36),102)izo,' elem ',iel,' gauss ',iga
  205. endif
  206. 102 format (I4,A6,i6,a7,i2)
  207. KEVTEX=IEVTEX
  208. ievoll(1)=kevoll
  209. iprogx=mlree1
  210. iprogy=mlree2
  211. numevx=icoul
  212. NUMEVY='REEL'
  213. NOMEVY=chalu(1:6) // ' '//noco
  214. NOMEVX='TEMPS'
  215. TYPX='LISTREEL'
  216. TYPY='LISTREEL'
  217. segdes mevoll,kevoll
  218. call ecrobj('EVOLUTIO',mevoll)
  219. return
  220. 100 continue
  221. segsup mlree1,mlree2
  222. return
  223. end
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  

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