Esope source files

   1 : C FANTOM    SOURCE    PV        08/09/11    21:15:52     6150           
   2 :       subroutine fantom
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8(A-H,O-Z)
   5 : -INC CCOPTIO
   6 : -INC CCNOYAU
   7 : -INC TMCOLAC
   8 :       logical ibool,ilogi
   9 :       character*8 icha,ichare,mcha2
  10 :       character*72 mcha
  11 :       if(ipsauv.eq.0) then
  11 :        call erreur(967)
  12 :        return
  13 :       endif
  14 : C      itout=0
  14 :       call quetyp ( icha,1,iretou)
  15 :       if(icha.ne.'TABLE' ) then
  16 :         moterr(1:8)='TABLE' 
  16 :         call erreur (37)
  17 :         return
  18 :       endif
  19 :       ichare=' '
  19 :       call lirobj(ichare,mtable,1,iretou)
  20 :       if ( ierr.ne.0) return
  20 :   1   call quetyp ( icha,1,iretou)
  21 :       if(ierr.ne.0) return
  22 : **    if( itout.eq.1.and.icha.ne.'ENTIER') then
  22 : **       call erreur (8)
  23 : **       return
  24 : **    endif
  25 :       if( icha.eq.'ENTIER' ) then
  25 :         call lirent (iva,1,iretou)
  26 :       elseif(icha.eq.'FLOTTANT' ) then
  26 :         call lirree(xva,1,iretou)
  27 :       elseif(icha.eq.'MOT' ) then
  27 :         call lircha(mcha,1,iretou)
  28 : C        if( mcha.eq.'TOUTSAUF') then
  29 : C          itout=1
  30 : C          goto 1
  31 : C        endif
  32 :       elseif(icha.eq.'LOGIQUE') then
  32 :         call lirlog(ilogi,1,iretou)
  33 :       else 
  33 :         call lirobj(icha,iva,1,iretou)
  34 :       endif      
  35 :       if(ierr.ne.0) return
  36 : C      if ( itout.eq.1) then
  37 : CC   recherche du max
  38 : C        ideb=0
  39 : C        do 2 ii=1,100000
  40 : C        ichare=' '
  40 : C        call acctab ( mtable,icha,ii,xva,mcha,ilogi,iva,
  41 : C     $                   ichare, ivb,xvb,mcha2,ibool,iobj)
  42 : C        if(ichare.eq.' ') then
  43 : C           ifin = ii - iva -1               
  44 : C           go to 3
  45 : C        endif
  46 : C   2    continue
  47 : C        ifin=ii-2
  48 : C   3    continue
  49 : C      else
  50 :         ideb=iva
  51 :         ifin=iva 
  52 : C      endif      
  53 :       do 4 iiva=ideb,ifin
  54 :       ichare=' '
  55 :       iobj=0
  55 :       call acctab ( mtable,icha,iiva,xva,mcha,ilogi,iiva,
  56 :      $                   ichare, ivb,xvb,mcha2,ibool,iobj)   
  57 :       if( ichare.eq.' ') then
  58 :            moterr(1:8) = icha
  59 :            interr(1)=iiva
  59 :            call erreur (171)
  60 :            return
  61 :       endif
  62 :       if(ichare.eq.'FANTOME ') return
  63 : *
  64 : * ici on test que l'objet a deja ete sauvé.
  65 : *
  66 :             
  67 :       if(iobj.eq.0) return
  68 : *      write(6,*) ' meffac  ',meffac
  69 :       if(meffac.eq.0) then
  70 :         neff =300
  71 :         segini meffac
  71 :         call savseg (meffac)
  72 :       else
  73 :         segact meffac*mod
  74 :       endif
  75 :       if( neffec.ge.neffac(/1)) then
  76 :          neff = neffac(/1) + 300
  77 :          segadj meffac
  78 :       endif 
  78 :       call typfil(ichare,jj)
  79 : *      write(6,*) ' ichare  jj ', ichare , jj
  80 :       icolac=ipsauv
  81 :       segact icolac
  82 :       itlacc = kcola(jj)
  83 :       segact itlacc
  84 :       naz = itlac(/1)
  85 :       do 10 i=1,naz
  86 :       if( itlac(i).eq.iobj) go to 20
  87 :   10  continue
  88 : 
  89 :       moterr(1:8)=ichare
  90 :       interr(1)=iobj
  90 :       call erreur(968)
  91 :       segdes itlacc,icolac,meffac
  92 :       return
  93 :   20  continue
  94 :       neffec=neffec+1 
  95 :       tyeffa(neffec)=ichare 
  96 :       neffac(neffec)=i
  97 :       neff=neffec
  98 : *       write(6,*) ' icha iiva neff ', icha, iiva,neff
  99 :       segdes meffac,itlacc,icolac
  99 :       call ecctab (mtable,icha,iiva,xva,mcha,ilogi,iiva,
 100 :      $     'FANTOME',iiva,xvb,mcha2,ibool,neff)  
 101 :     4 continue
 102 :       return
 103 :       end
 104 :  
 105 :