Numérotation des lignes :

C EXTERN    SOURCE    PV        18/10/17    11:49:10     9965           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      ith=oothrd*     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 WIN32,WIN64      call ecrdon(buff,lpos,ith)%ELSE      if (lpos .gt. 1) call ecrdon(buff,lpos,ith)%ENDIF      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

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