Télécharger fillpo.eso

Retour à la liste

Numérotation des lignes :

  1. C FILLPO SOURCE PV 17/12/05 21:16:22 9646
  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=ILISSF
  40. SEGACT ILISSE*MOD
  41. ILISSE=ILISSP
  42. SEGACT ILISSE*MOD
  43. ILISSE=ILISSG
  44. SEGACT ILISSE*MOD
  45. CALL LISTOB(MTYP,MLON,IBID,0)
  46. SEGINI ILISBB
  47. C---- IN = taille du tableau des types dans MLCHAR
  48. DO 3 II=1,IN
  49.  
  50. MTYP=MLCHAR(II)
  51.  
  52. IF (IIMPI.EQ.5) WRITE(IOIMP,101) MTYP
  53.  
  54. K=0
  55. CALL TYPFIL (MTYP,K)
  56.  
  57. C------- Si MTYP = ' ' ou un type inconnu par TYPFIL, K devient -NPOSSI
  58. C dans ce cas la, on va traiter le suivant
  59. IF (K.LE.0) THEN
  60. C --------- ICI UN WRITE PILE NON TRAITEE
  61. MOTERR(1:8)=MLCHAR(II)
  62. GO TO 3
  63. ENDIF
  64.  
  65. C ------ Sinon :
  66. 7 CONTINUE
  67. CALL LISTOB(MTYP,ITITI,ILISOB,1)
  68. IF (ITITI.EQ.0) GO TO 3
  69. ITLACC=KCOLA(K)
  70. NUMLIS=1
  71. ilissd=ilisse
  72. ITYP=K
  73. IF(ITYP.EQ.24) NUMLIS=6
  74. IF(ITYP.EQ.25) then
  75. NUMLIS=3
  76. ilissd=ilissf
  77. ENDIF
  78. IF(ITYP.EQ.26) NUMLIS=2
  79. IF(ITYP.EQ.27) NUMLIS=5
  80. IF(ITYP.EQ.32) then
  81. NUMLIS=3
  82. ilissd=ilissp
  83. ENDIF
  84. IF(ITYP.EQ.36) NUMLIS=7
  85. DO 10 I=1,ITITI
  86. IOBVAL=ILISOB(I)
  87. IF(IIMPI.EQ.5) WRITE(IOIMP,102) MTYP,IOBVAL
  88. *
  89. * cas particulier des procedures non deja decodée
  90. IF(ITYP.EQ.36.AND.IOBVAL.LE.0) GO TO 10
  91. C---------- Rajoute l'objet IOBVAL sur la pile ITLACC s'il n'y est pas encore
  92. C La valeur IOBVAL en sortie contient son numero sur la pile, elle
  93. C est ici ignoree
  94. CALL AJOUN (ITLACC,IOBVAL,ILISSd,NUMLIS)
  95. 10 CONTINUE
  96. C
  97. 3 CONTINUE
  98. * la liste des objets esclaves s'obtient en plus a partir des mesins
  99. CALL TYPFIL ('ESCLAVE ',K)
  100. CALL TYPFIL ('LISTMOTS',K1)
  101. * write (6,*) ' fillpo numero de la pile esclave ',k
  102. itlac2=kcola(k)
  103. itlac1=kcola(k1)
  104. if (nbesc.ne.0) then
  105. do 20 ith=0,nbesc
  106. mesins=mescl(ith)
  107. if (mesins.eq.0) goto 20
  108. segact mesins*mod
  109. do 30 ins=0,nbins
  110. if (ins.eq.0) then
  111. mescla=inscou
  112. if (mescla.eq.0) goto 30
  113. else
  114. mescla=lismes(ins)
  115. endif
  116. segact mescla
  117. mlmot1=jpcar1
  118. numlis=1
  119. if (mlmot1.ne.0) call ajoun(itlac1,mlmot1,ilisse,numlis)
  120. do 40 ies=1,100
  121. if (esrees(ies).eq.0) goto 40
  122. mesres=esrees(ies)
  123. numlis=1
  124. * write (6,*) ' fillp2 ajout de l esclave ',mesres
  125. call ajoun(itlac2,mesres,ilisse,numlis)
  126. 40 continue
  127. * il faut aussi rajouter les objet contenus dans les instructions en attente sur
  128. * les esclaves
  129. do 50 iop=1,100
  130. if (esoplu(iop)) goto 50
  131. mtyp=esopty(iop)
  132. K=0
  133. CALL TYPFIL (MTYP,K)
  134. IF (K.LE.0) THEN
  135. C --------- ICI UN WRITE PILE NON TRAITEE
  136. MOTERR(1:8)=MLCHAR(II)
  137. GO TO 8
  138. ENDIF
  139. ITLACC=KCOLA(K)
  140. NUMLIS=1
  141. ilissd=ilisse
  142. ITYP=K
  143. IF(ITYP.EQ.24) NUMLIS=6
  144. IF(ITYP.EQ.25) then
  145. NUMLIS=3
  146. ilissd=ilissf
  147. endif
  148. IF(ITYP.EQ.26) NUMLIS=2
  149. IF(ITYP.EQ.27) NUMLIS=5
  150. IF(ITYP.EQ.32) then
  151. NUMLIS=3
  152. ilissd=ilissp
  153. endif
  154. IF(ITYP.EQ.36) NUMLIS=7
  155. * logique
  156. IF(ITYP.EQ.24) goto 50
  157. * flottant
  158. IF(ITYP.EQ.25) goto 50
  159. * entier
  160. IF(ITYP.EQ.26) goto 50
  161. * mot
  162. IF(ITYP.EQ.27) goto 50
  163. iobval=esopva(iop)
  164. * write (6,*) ' fillpo instruction contient ', mtyp,iobval
  165. CALL AJOUN (ITLACC,IOBVAL,ILISSD,NUMLIS)
  166. 50 continue
  167. segdes mescla
  168. 30 continue
  169. segdes mesins*record
  170. 20 continue
  171. endif
  172. SEGSUP ILISBB
  173. * SEGDES ILISSE
  174. SEGDES ICOLAC
  175. 8 SEGDES MLCHA8
  176. RETURN
  177. C -------------------------------------
  178. 102 FORMAT(1X,8(1X,A8,I15))
  179. 101 FORMAT (/,' OBJETS DE TYPE ',A8)
  180. END
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  

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