Sources Esope | Cast3M

fantom
C FANTOM    SOURCE    PV        17/12/05    21:16:18     9646           
      subroutine fantom
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCNOYAU
-INC TMCOLAC
      logical ibool,ilogi
      character*8 icha,ichare,mcha2
      character*72 mcha
      if(ipsauv.eq.0) then
       call erreur(967)
       return
      endif
C      itout=0
      call quetyp ( icha,1,iretou)
      if(icha.ne.'TABLE' ) then
        moterr(1:8)='TABLE'
        call erreur (37)
        return
      endif
      ichare=' '
      call lirobj(ichare,mtable,1,iretou)
      if ( ierr.ne.0) return
  1   call quetyp ( icha,1,iretou)
      if(ierr.ne.0) return
**    if( itout.eq.1.and.icha.ne.'ENTIER') then
**       call erreur (8)
**       return
**    endif
      if( icha.eq.'ENTIER' ) then
        call lirent (iva,1,iretou)
      elseif(icha.eq.'FLOTTANT' ) then
        call lirree(xva,1,iretou)
      elseif(icha.eq.'MOT' ) then
        call lircha(mcha,1,iretou)
C        if( mcha.eq.'TOUTSAUF') then
C          itout=1
C          goto 1
C        endif
      elseif(icha.eq.'LOGIQUE') then
        call lirlog(ilogi,1,iretou)
      else
        call lirobj(icha,iva,1,iretou)
      endif
      if(ierr.ne.0) return
C      if ( itout.eq.1) then
CC   recherche du max
C        ideb=0
C        do 2 ii=1,100000
C        ichare=' '
C        call acctab ( mtable,icha,ii,xva,mcha,ilogi,iva,
C     $                   ichare, ivb,xvb,mcha2,ibool,iobj)
C        if(ichare.eq.' ') then
C           ifin = ii - iva -1
C           go to 3
C        endif
C   2    continue
C        ifin=ii-2
C   3    continue
C      else
        ideb=iva
        ifin=iva
C      endif
      do 4 iiva=ideb,ifin
      ichare=' '
      iobj=0
      call acctab ( mtable,icha,iiva,xva,mcha,ilogi,iiva,
     $                   ichare, ivb,xvb,mcha2,ibool,iobj)
      if( ichare.eq.' ') then
           moterr(1:8) = icha
           interr(1)=iiva
           call erreur (171)
           return
      endif
      if(ichare.eq.'FANTOME ') return
*
* ici on test que l'objet a deja ete sauvé.
*
 
      if(iobj.eq.0) return
*      write(6,*) ' meffac  ',meffac
      if(meffac.eq.0) then
        neff =300
        segini meffac
        call savseg (meffac)
      else
        segact meffac*mod
      endif
      if( neffec.ge.neffac(/1)) then
         neff = neffac(/1) + 300
         segadj meffac
      endif
      call typfil(ichare,jj)
*      write(6,*) ' ichare  jj ', ichare , jj
      icolac=ipsauv
      segact icolac
      itlacc = kcola(jj)
      segact itlacc
      naz = itlac(/1)
      do 10 i=1,naz
      if( itlac(i).eq.iobj) go to 20
  10  continue
 
      moterr(1:8)=ichare
      interr(1)=iobj
      call erreur(968)
      segdes itlacc,icolac,meffac
      return
  20  continue
      neffec=neffec+1
      tyeffa(neffec)=ichare
      neffac(neffec)=i
      neff=neffec
*       write(6,*) ' icha iiva neff ', icha, iiva,neff
      segdes meffac,itlacc,icolac
      call ecctab (mtable,icha,iiva,xva,mcha,ilogi,iiva,
     $     'FANTOME',iiva,xvb,mcha2,ibool,neff)
    4 continue
      return
      end