Télécharger fantom.eso

Retour à la liste

Numérotation des lignes :

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

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