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