C EXTERN SOURCE PV 13/02/28 21:15:11 7701 C interface vers un programme exterieur subroutine extern IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCOPTIO -INC CCREDLE -INC SMTABLE -INC SMLREEL -INC SMLENTI external long segment sbuff character*1 buff(lbuf) endsegment logical bid character*500 lacomm character*500 cmtext character*8 icha character*72 motbuf ith=0 call ooonth(ith) * write (6,*) ' ith vaut ',ith call lircha(lacomm,1,iretou) l=long(lacomm) moterr=lacomm(1:l) call lance (lacomm(1:l)//char(0),ith) * ecriture des donnees lbuf=1000 lpos=0 segini sbuff 100 continue if (lpos+510.gt.lbuf) then lbuf=lbuf+1000 segadj sbuff endif call quetyp(icha,0,iretou) if (iretou.eq.0) goto 200 if (icha.eq.'TABLE ') then icha=' ' call lirobj(icha,mtable,1,iretou) segact mtable do 120 ipot=1,mlotab if (lpos+510.gt.lbuf) then lbuf=lbuf+1000 segadj sbuff endif do 130 ipou=1,mlotab if (mtabti(ipou).ne.'ENTIER ') goto 130 if (mtabii(ipou).ne.ipot) goto 130 goto 140 130 continue goto 120 140 continue icha=mtabtv(ipou) if (icha.eq.'ENTIER ') then ient=mtabiv(ipou) write (buff(lpos+1)(1:10),fmt='(i10)') ient lpos=lpos+11 buff(lpos)=' ' goto 120 elseif (icha.eq.'FLOTTANT') then xv=rmtabv(ipou) write (buff(lpos+1)(1:21),fmt='(e21.15)') xv lpos=lpos+22 buff(lpos)=' ' goto 120 elseif (icha.eq.'LISTREEL') then mlreel=mtabiv(ipou) segact mlreel lprog=prog(/1) if (lpos+22*lprog.gt.lbuf) then lbuf=lbuf+1000+22*lprog segadj sbuff endif write (buff(lpos+1)(1:22*lprog),fmt='(2000000000(e21.15,x))') > (prog(jg),jg=1,lprog) lpos=lpos+22*lprog segdes mlreel goto 120 elseif (icha.eq.'LISTENTI') then mlenti=mtabiv(ipou) segact mlenti llect=lect(/1) if (lpos+11*llect.gt.lbuf) then lbuf=lbuf+1000+11*llect segadj sbuff endif write (buff(lpos+1)(1:11*llect),fmt='(2000000000(i10,x))') > (lect(jg),jg=1,llect) lpos=lpos+11*llect segdes mlenti goto 120 elseif (icha.eq.'MOT ') then call acctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0, > 'MOT ',ient,xv,lacomm,bid,iseg) segact mtable lcom=long(lacomm) if (lacomm(1:lcom).eq.'RC') then lacomm(1:1)=char(10) lcom=1 endif buff(lpos+1)(1:lcom)=lacomm(1:lcom) lpos=lpos+lcom+1 buff(lpos)=' ' goto 120 endif 120 continue segdes mtable goto 100 elseif (icha.eq.'ENTIER ') then call lirent(ient,1,iretou) write (buff(lpos+1)(1:10),fmt='(i10)') ient lpos=lpos+11 buff(lpos)=' ' goto 100 elseif (icha.eq.'FLOTTANT') then call lirree(xv,1,iretou) write (buff(lpos+1)(1:21),fmt='(e21.15)') xv lpos=lpos+22 buff(lpos)=' ' goto 100 elseif (icha.eq.'LISTREEL') then call lirobj('LISTREEL',mlreel,1,iretou) segact mlreel lprog=prog(/1) if (lpos+22*lprog.gt.lbuf) then lbuf=lbuf+1000+22*lprog segadj sbuff endif write (buff(lpos+1)(1:22*lprog),fmt='(2000000000(e21.15,x))') > (prog(jg),jg=1,lprog) lpos=lpos+22*lprog segdes mlreel goto 100 elseif (icha.eq.'LISTENTI') then call lirobj('LISTENTI',mlenti,1,iretou) segact mlenti llect=lect(/1) if (lpos+11*llect.gt.lbuf) then lbuf=lbuf+1000+11*llect segadj sbuff endif write (buff(lpos+1)(1:11*llect),fmt='(2000000000(i10,x))') > (lect(jg),jg=1,llect) lpos=lpos+11*llect segdes mlenti goto 100 elseif (icha.eq.'MOT ') then call lircha(lacomm,1,iretou) lcom=long(lacomm) if (lacomm(1:lcom).eq.'RC') then lacomm(1:1)=char(10) lcom=1 endif buff(lpos+1)(1:lcom)=lacomm(1:lcom) lpos=lpos+lcom+1 buff(lpos)=' ' goto 100 endif 200 continue lpos=lpos+1 buff(lpos)=char(10) if (lpos .gt. 1) call ecrdon(buff,lpos,ith) segsup sbuff * creation du resultat m=100 segini mtable mlotab=0 call ecrobj('TABLE ',mtable) * sauvegarde de l'etat de redlec * cmtext(1:500)=text(1:500) * nran1=nran * icour1=icour * ifina1=ifinan * iprec1=iprec * ipos1=ipos call inired(sredle) nran=0 ifinan=73 icour=72 ipo=0 10 continue * boucle jusqu'a un rc call lires(text(ipo+1:72+ipo),iend,istat,ith) icour=iend+ipo * write (6,*) ' iend ',iend,ichar(text(iend:iend)) * virer les retours chariots text(ipo+iend+1:500)=' ' do 5 i=ipo+1,ipo+72 if (text(i:i).eq.char(10)) text(i:i)=' ' if (text(i:i).eq.char(13)) text(i:i)=' ' 5 continue 20 continue call redlec(sredle) ipot=mlotab+1 if (ipot.gt.mtabti(/2)) then m=mtabti(/2)+256 segadj mtable endif motbuf(1:ncar)=mot(1:ncar) ncas=ncar if (ire.eq.1) then mlotab=ipot mtabti(mlotab)='ENTIER' mtabii(mlotab)=mlotab mtabtv(mlotab)='ENTIER' mtabiv(mlotab)=nfix * call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0, * > 'ENTIER ',nfix,0.D0,' ',.true.,0) elseif (ire.eq.2) then mlotab=ipot mtabti(mlotab)='ENTIER' mtabii(mlotab)=mlotab mtabtv(mlotab)='FLOTTANT' rmtabv(mlotab)=flot * call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0, * > 'FLOTTANT',0,flot,' ',.true.,0) elseif (ire.eq.3) then call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0, > 'MOT ',0,0.D0,motbuf(1:ncas),.true.,0) segact mtable*mod elseif (ire.eq.4) then call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0, > 'MOT ',0,0.D0,motbuf(1:ncas),.true.,0) segact mtable*mod * elseif (ire.eq.5) then * call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0, * > 'MOT ',0,0.D0,motbuf(1:ncas),.true.,0) elseif (ire.eq.6) then call ecctab(mtable,'ENTIER ',ipot,0.D0,' ',.true.,0, > 'MOT ',0,0.D0,motbuf(1:ncas),.true.,0) segact mtable*mod else if (iend.le.0) goto 50 goto 10 endif * write (6,*) ' dans extern ',nran,icour if (iend.gt.0) then if (ipo+iend-nran.le.32) then text(1:500)=text(nran+1:ipo+iend) ipo=max(0,ipo+iend-nran) nran=0 goto 10 endif endif goto 20 50 continue segdes mtable * restauration de l'etat de redlec * text(1:500)=cmtext(1:500) * nran=nran1 * icour=icour1 * ifinan=ifina1 * iprec=iprec1 * ipos=ipos1 segsup sredle * test de completion de la commande interr(1)=istat if (istat.ne.0) call erreur(873) return end