Télécharger fillpo.eso

Retour à la liste

Numérotation des lignes :

  1. C FILLPO SOURCE PV 16/11/26 21:15:54 9205
  2. SUBROUTINE FILLPO (ICOLAC,MTY)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C-----------------------------------------------------------------
  6. C A PARTIR DE TOUS LES TYPES EXISTANTS REMPLIT LES PILES
  7. C CONNUES ET TRAITEES PAR TYPFIL
  8. C ENTREE: MTY POINTEUR SUR LE SEGMENT DES TYPES A TRAITER
  9. C LES PILES DOIVENT AVOIR ETE CREES ET INITIALISEES AUPARAVANT
  10. C APPELE PAR : SAUV
  11. C APPELLE : REPERT AJOUN ERREUR
  12. C-----------------------------------------------------------------
  13. -INC CCOPTIO
  14. -INC TMLCHA8
  15. -INC TMCOLAC
  16. -INC CCASSIS
  17. common/pil/itabb
  18. SEGMENT ILISBB
  19. INTEGER ILISOB(MLON)
  20. ENDSEGMENT
  21. DIMENSION IBID(1)
  22. CHARACTER*(1) CHARIN
  23. LOGICAL LOGIN
  24. REAL*8 XVA
  25. CHARACTER*(8) MTYP
  26. C---------------------------------------------------------------------
  27. MLCHA8=MTY
  28. SEGACT MLCHA8
  29. IN=MLCHAR(/2)
  30.  
  31. C---- S'il n'y a rien dans MLCHA8 on s'en va
  32. IF (IN.EQ.0) GO TO 8
  33.  
  34. IF (IIMPI.EQ.5) WRITE(IOIMP,800)(MLCHAR(I),I=1,IN)
  35. 800 FORMAT (' LISTE DES TYPES A SAUVER',/(2X,A8))
  36.  
  37. SEGACT ICOLAC
  38. itabb=kcola(39)
  39. ILISSE=ILISSG
  40. SEGACT ILISSE*MOD
  41. CALL LISTOB(MTYP,MLON,IBID,0)
  42. SEGINI ILISBB
  43. C---- IN = taille du tableau des types dans MLCHAR
  44. DO 3 II=1,IN
  45.  
  46. MTYP=MLCHAR(II)
  47.  
  48. IF (IIMPI.EQ.5) WRITE(IOIMP,101) MTYP
  49.  
  50. K=0
  51. CALL TYPFIL (MTYP,K)
  52.  
  53. C------- Si MTYP = ' ' ou un type inconnu par TYPFIL, K devient -NPOSSI
  54. C dans ce cas la, on va traiter le suivant
  55. IF (K.LE.0) THEN
  56. C --------- ICI UN WRITE PILE NON TRAITEE
  57. MOTERR(1:8)=MLCHAR(II)
  58. GO TO 3
  59. ENDIF
  60.  
  61. C ------ Sinon :
  62. 7 CONTINUE
  63. CALL LISTOB(MTYP,ITITI,ILISOB,1)
  64. IF (ITITI.EQ.0) GO TO 3
  65. ITLACC=KCOLA(K)
  66. NUMLIS=1
  67. ilissd=ilisse
  68. ITYP=K
  69. IF(ITYP.EQ.24) NUMLIS=6
  70. IF(ITYP.EQ.25) NUMLIS=4
  71. IF(ITYP.EQ.26) NUMLIS=2
  72. IF(ITYP.EQ.27) NUMLIS=5
  73. IF(ITYP.EQ.32) then
  74. NUMLIS=3
  75. ilissd=ilissp
  76. ENDIF
  77. IF(ITYP.EQ.36) NUMLIS=7
  78. DO 10 I=1,ITITI
  79. IOBVAL=ILISOB(I)
  80. IF(IIMPI.EQ.5) WRITE(IOIMP,102) MTYP,IOBVAL
  81. *
  82. * cas particulier des procedures non deja decodée
  83. IF(ITYP.EQ.36.AND.IOBVAL.LE.0) GO TO 10
  84. C---------- Rajoute l'objet IOBVAL sur la pile ITLACC s'il n'y est pas encore
  85. C La valeur IOBVAL en sortie contient son numero sur la pile, elle
  86. C est ici ignoree
  87. CALL AJOUN (ITLACC,IOBVAL,ILISSd,NUMLIS)
  88. 10 CONTINUE
  89. C
  90. 3 CONTINUE
  91. * la liste des objets esclaves s'obtient en plus a partir des mesins
  92. CALL TYPFIL ('ESCLAVE ',K)
  93. CALL TYPFIL ('LISTMOTS',K1)
  94. * write (6,*) ' fillpo numero de la pile esclave ',k
  95. itlac2=kcola(k)
  96. itlac1=kcola(k1)
  97. if (nbesc.ne.0) then
  98. do 20 ith=0,nbesc
  99. mesins=mescl(ith)
  100. if (mesins.eq.0) goto 20
  101. segact mesins*mod
  102. do 30 ins=0,nbins
  103. if (ins.eq.0) then
  104. mescla=inscou
  105. if (mescla.eq.0) goto 30
  106. else
  107. mescla=lismes(ins)
  108. endif
  109. segact mescla
  110. mlmot1=jpcar1
  111. numlis=1
  112. if (mlmot1.ne.0) call ajoun(itlac1,mlmot1,ilisse,numlis)
  113. do 40 ies=1,100
  114. if (esrees(ies).eq.0) goto 40
  115. mesres=esrees(ies)
  116. numlis=1
  117. * write (6,*) ' fillp2 ajout de l esclave ',mesres
  118. call ajoun(itlac2,mesres,ilisse,numlis)
  119. 40 continue
  120. * il faut aussi rajouter les objet contenus dans les instructions en attente sur
  121. * les esclaves
  122. do 50 iop=1,100
  123. if (esoplu(iop)) goto 50
  124. mtyp=esopty(iop)
  125. K=0
  126. CALL TYPFIL (MTYP,K)
  127. IF (K.LE.0) THEN
  128. C --------- ICI UN WRITE PILE NON TRAITEE
  129. MOTERR(1:8)=MLCHAR(II)
  130. GO TO 8
  131. ENDIF
  132. ITLACC=KCOLA(K)
  133. NUMLIS=1
  134. ilissd=ilisse
  135. ITYP=K
  136. IF(ITYP.EQ.24) NUMLIS=6
  137. IF(ITYP.EQ.25) NUMLIS=4
  138. IF(ITYP.EQ.26) NUMLIS=2
  139. IF(ITYP.EQ.27) NUMLIS=5
  140. IF(ITYP.EQ.32) then
  141. NUMLIS=3
  142. ilissd=ilissp
  143. endif
  144. IF(ITYP.EQ.36) NUMLIS=7
  145. * logique
  146. IF(ITYP.EQ.24) goto 50
  147. * flottant
  148. IF(ITYP.EQ.25) goto 50
  149. * entier
  150. IF(ITYP.EQ.26) goto 50
  151. * mot
  152. IF(ITYP.EQ.27) goto 50
  153. iobval=esopva(iop)
  154. * write (6,*) ' fillpo instruction contient ', mtyp,iobval
  155. CALL AJOUN (ITLACC,IOBVAL,ILISSD,NUMLIS)
  156. 50 continue
  157. segdes mescla
  158. 30 continue
  159. segdes mesins*record
  160. 20 continue
  161. endif
  162. SEGSUP ILISBB
  163. * SEGDES ILISSE
  164. SEGDES ICOLAC
  165. 8 SEGDES MLCHA8
  166. RETURN
  167. C -------------------------------------
  168. 102 FORMAT(1X,8(1X,A8,I15))
  169. 101 FORMAT (/,' OBJETS DE TYPE ',A8)
  170. END
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  

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