Télécharger evtem1.eso

Retour à la liste

Numérotation des lignes :

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

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