Télécharger extern.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTERN SOURCE CB215821 16/09/22 21:15:02 9101
  2. C interface vers un programme exterieur
  3. subroutine extern
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. -INC CCOPTIO
  7. -INC CCREDLE
  8. -INC SMTABLE
  9. -INC SMLREEL
  10. -INC SMLENTI
  11. external long
  12. segment sbuff
  13. character*1 buff(lbuf)
  14. endsegment
  15. logical bid
  16. character*500 lacomm
  17. character*500 cmtext
  18. character*8 icha
  19. character*72 motbuf
  20. ith=0
  21. call ooonth(ith)
  22. * write (6,*) ' ith vaut ',ith
  23. call lircha(lacomm,1,iretou)
  24. l=long(lacomm)
  25. moterr=lacomm(1:l)
  26. call lance (lacomm(1:l)//char(0),ith)
  27. * ecriture des donnees
  28. lbuf=1000
  29. lpos=0
  30. segini sbuff
  31. 100 continue
  32. if (lpos+510.gt.lbuf) then
  33. lbuf=lbuf+1000
  34. segadj sbuff
  35. endif
  36. call quetyp(icha,0,iretou)
  37. if (iretou.eq.0) goto 200
  38. if (icha.eq.'TABLE ') then
  39. icha=' '
  40. call lirobj(icha,mtable,1,iretou)
  41. segact mtable
  42. do 120 ipot=1,mlotab
  43. if (lpos+510.gt.lbuf) then
  44. lbuf=lbuf+1000
  45. segadj sbuff
  46. endif
  47. do 130 ipou=1,mlotab
  48. if (mtabti(ipou).ne.'ENTIER ') goto 130
  49. if (mtabii(ipou).ne.ipot) goto 130
  50. goto 140
  51. 130 continue
  52. goto 120
  53. 140 continue
  54. icha=mtabtv(ipou)
  55. if (icha.eq.'ENTIER ') then
  56. ient=mtabiv(ipou)
  57. write (buff(lpos+1)(1:10),fmt='(i10)') ient
  58. lpos=lpos+11
  59. buff(lpos)=' '
  60. goto 120
  61. elseif (icha.eq.'FLOTTANT') then
  62. xv=rmtabv(ipou)
  63. write (buff(lpos+1)(1:21),fmt='(e21.15)') xv
  64. lpos=lpos+22
  65. buff(lpos)=' '
  66. goto 120
  67. elseif (icha.eq.'LISTREEL') then
  68. mlreel=mtabiv(ipou)
  69. segact mlreel
  70. lprog=prog(/1)
  71. if (lpos+22*lprog.gt.lbuf) then
  72. lbuf=lbuf+1000+22*lprog
  73. segadj sbuff
  74. endif
  75. write (buff(lpos+1)(1:22*lprog),fmt='(2000000000(e21.15,x))')
  76. > (prog(jg),jg=1,lprog)
  77. lpos=lpos+22*lprog
  78. segdes mlreel
  79. goto 120
  80. elseif (icha.eq.'LISTENTI') then
  81. mlenti=mtabiv(ipou)
  82. segact mlenti
  83. llect=lect(/1)
  84. if (lpos+11*llect.gt.lbuf) then
  85. lbuf=lbuf+1000+11*llect
  86. segadj sbuff
  87. endif
  88. write (buff(lpos+1)(1:11*llect),fmt='(2000000000(i10,x))')
  89. > (lect(jg),jg=1,llect)
  90. lpos=lpos+11*llect
  91. segdes mlenti
  92. goto 120
  93. elseif (icha.eq.'MOT ') then
  94. call acctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0,
  95. > 'MOT ',ient,xv,lacomm,bid,iseg)
  96. segact mtable
  97. lcom=long(lacomm)
  98. if (lacomm(1:lcom).eq.'RC') then
  99. lacomm(1:1)=char(10)
  100. lcom=1
  101. endif
  102. buff(lpos+1)(1:lcom)=lacomm(1:lcom)
  103. lpos=lpos+lcom+1
  104. buff(lpos)=' '
  105. goto 120
  106. endif
  107. 120 continue
  108. segdes mtable
  109. goto 100
  110. elseif (icha.eq.'ENTIER ') then
  111. call lirent(ient,1,iretou)
  112. write (buff(lpos+1)(1:10),fmt='(i10)') ient
  113. lpos=lpos+11
  114. buff(lpos)=' '
  115. goto 100
  116. elseif (icha.eq.'FLOTTANT') then
  117. call lirree(xv,1,iretou)
  118. write (buff(lpos+1)(1:21),fmt='(e21.15)') xv
  119. lpos=lpos+22
  120. buff(lpos)=' '
  121. goto 100
  122. elseif (icha.eq.'LISTREEL') then
  123. call lirobj('LISTREEL',mlreel,1,iretou)
  124. segact mlreel
  125. lprog=prog(/1)
  126. if (lpos+22*lprog.gt.lbuf) then
  127. lbuf=lbuf+1000+22*lprog
  128. segadj sbuff
  129. endif
  130. write (buff(lpos+1)(1:22*lprog),fmt='(2000000000(e21.15,x))')
  131. > (prog(jg),jg=1,lprog)
  132. lpos=lpos+22*lprog
  133. segdes mlreel
  134. goto 100
  135. elseif (icha.eq.'LISTENTI') then
  136. call lirobj('LISTENTI',mlenti,1,iretou)
  137. segact mlenti
  138. llect=lect(/1)
  139. if (lpos+11*llect.gt.lbuf) then
  140. lbuf=lbuf+1000+11*llect
  141. segadj sbuff
  142. endif
  143. write (buff(lpos+1)(1:11*llect),fmt='(2000000000(i10,x))')
  144. > (lect(jg),jg=1,llect)
  145. lpos=lpos+11*llect
  146. segdes mlenti
  147. goto 100
  148. elseif (icha.eq.'MOT ') then
  149. call lircha(lacomm,1,iretou)
  150. lcom=long(lacomm)
  151. if (lacomm(1:lcom).eq.'RC') then
  152. lacomm(1:1)=char(10)
  153. lcom=1
  154. endif
  155. buff(lpos+1)(1:lcom)=lacomm(1:lcom)
  156. lpos=lpos+lcom+1
  157. buff(lpos)=' '
  158. goto 100
  159. endif
  160. 200 continue
  161. lpos=lpos+1
  162. buff(lpos)=char(10)
  163. %IF WIN32,WIN64
  164. call ecrdon(buff,lpos,ith)
  165. %ELSE
  166. if (lpos .gt. 1) call ecrdon(buff,lpos,ith)
  167. %ENDIF
  168. segsup sbuff
  169. * creation du resultat
  170. m=100
  171. segini mtable
  172. mlotab=0
  173. call ecrobj('TABLE ',mtable)
  174. * sauvegarde de l'etat de redlec
  175. * cmtext(1:500)=text(1:500)
  176. * nran1=nran
  177. * icour1=icour
  178. * ifina1=ifinan
  179. * iprec1=iprec
  180. * ipos1=ipos
  181. call inired(sredle)
  182. nran=0
  183. ifinan=73
  184. icour=72
  185. ipo=0
  186. 10 continue
  187. * boucle jusqu'a un rc
  188. call lires(text(ipo+1:72+ipo),iend,istat,ith)
  189. icour=iend+ipo
  190. * write (6,*) ' iend ',iend,ichar(text(iend:iend))
  191. * virer les retours chariots
  192. text(ipo+iend+1:500)=' '
  193. do 5 i=ipo+1,ipo+72
  194. if (text(i:i).eq.char(10)) text(i:i)=' '
  195. if (text(i:i).eq.char(13)) text(i:i)=' '
  196. 5 continue
  197. 20 continue
  198. call redlec(sredle)
  199. ipot=mlotab+1
  200. if (ipot.gt.mtabti(/2)) then
  201. m=mtabti(/2)+256
  202. segadj mtable
  203. endif
  204. motbuf(1:ncar)=mot(1:ncar)
  205. ncas=ncar
  206. if (ire.eq.1) then
  207. mlotab=ipot
  208. mtabti(mlotab)='ENTIER'
  209. mtabii(mlotab)=mlotab
  210. mtabtv(mlotab)='ENTIER'
  211. mtabiv(mlotab)=nfix
  212. * call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0,
  213. * > 'ENTIER ',nfix,0.D0,' ',.true.,0)
  214. elseif (ire.eq.2) then
  215. mlotab=ipot
  216. mtabti(mlotab)='ENTIER'
  217. mtabii(mlotab)=mlotab
  218. mtabtv(mlotab)='FLOTTANT'
  219. rmtabv(mlotab)=flot
  220. * call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0,
  221. * > 'FLOTTANT',0,flot,' ',.true.,0)
  222. elseif (ire.eq.3) then
  223. call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0,
  224. > 'MOT ',0,0.D0,motbuf(1:ncas),.true.,0)
  225. segact mtable*mod
  226. elseif (ire.eq.4) then
  227. call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0,
  228. > 'MOT ',0,0.D0,motbuf(1:ncas),.true.,0)
  229. segact mtable*mod
  230. * elseif (ire.eq.5) then
  231. * call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0,
  232. * > 'MOT ',0,0.D0,motbuf(1:ncas),.true.,0)
  233. elseif (ire.eq.6) then
  234. call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0,
  235. > 'MOT ',0,0.D0,motbuf(1:ncas),.true.,0)
  236. segact mtable*mod
  237. else
  238. if (iend.le.0) goto 50
  239. goto 10
  240. endif
  241. * write (6,*) ' dans extern ',nran,icour
  242. if (iend.gt.0) then
  243. if (ipo+iend-nran.le.32) then
  244. text(1:500)=text(nran+1:ipo+iend)
  245. ipo=max(0,ipo+iend-nran)
  246. nran=0
  247. goto 10
  248. endif
  249. endif
  250. goto 20
  251. 50 continue
  252. segdes mtable
  253. * restauration de l'etat de redlec
  254. * text(1:500)=cmtext(1:500)
  255. * nran=nran1
  256. * icour=icour1
  257. * ifinan=ifina1
  258. * iprec=iprec1
  259. * ipos=ipos1
  260. segsup sredle
  261. * test de completion de la commande
  262. interr(1)=istat
  263. if (istat.ne.0) call erreur(873)
  264. return
  265. end
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  

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