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

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