Télécharger repete.eso

Retour à la liste

Numérotation des lignes :

  1. C REPETE SOURCE JC220346 16/07/08 21:15:04 9008
  2. C CET OPERATEUR INITIALISE LA FONCTION REPETER DE GIBIANE
  3. C IL DOIT ETRE SUIVI DU NOM D'UN BLOC REPETER
  4. C SI CE BLOC EXISTE LIRNOM EST DEROUTE POUR LE LIRE
  5. C SI CE BLOC N'EXISTE PAS IL LE CREE ET LIRNOM LE REMPLIT
  6. C A LA PREMIERE INTERPRETATION
  7. C LE BLOC FINI PAR FIN "BLOC"
  8. C
  9. SUBROUTINE REPETE
  10. IMPLICIT INTEGER(I-N)
  11. -INC SMBLOC
  12. -INC CCNOYAU
  13. -INC CCOPTIO
  14. CHARACTER*(8) ICHA,INOM,ITCH,ICHC
  15. CHARACTER*(9) ICHB
  16. *
  17. CHARACTER*8 IJCH
  18. CHARACTER*4 MFIN(1)
  19. DIMENSION IMOTCO(1)
  20. SAVE IMOTCO
  21. DATA IMOTCO(1)/-1/
  22. DATA MFIN/'FIN '/
  23. LOGICAL TSTMBC
  24. MBC=-1
  25. CALL LIROBJ('BLOC ',MBLO1,0,IREBLO)
  26. if( ireblo.ne.0) imablu=jpoob2(imotlu)
  27. IF(IREBLO.EQ.0) THEN
  28. CALL QUETYP(ICHA,1,IRETOU)
  29. IF(IERR.NE.0) RETURN
  30. IF(ICHA.EQ.'MOT ') THEN
  31. CALL LIRCHA(ICHB,1,IRETOU)
  32. IF(ICHB(9:9).NE.' ') THEN
  33. CALL ERREUR (315)
  34. RETURN
  35. ENDIF
  36. ICHA=ICHB
  37. ELSE
  38. CALL LIROBJ(ICHA,IRE,1,IRETOU)
  39. CALL QUENOM ( ICHA)
  40. IF(ICHA(1:1).EQ.' ') THEN
  41. CALL ERREUR(315)
  42. RETURN
  43. ENDIF
  44. ENDIF
  45. ENDIF
  46. CALL LIRENT(MBC,0,IRETOU)
  47. IF (IERR.NE.0) RETURN
  48. * TEST QUE L'INSTRUCTION EST EPUISEE - PROBLEME AVEC LA PRECOMPILATION
  49. * CALL QUETYP(ITCH,0,IRETO)
  50. * IF (IRETO.EQ.0) GOTO 20
  51. * MOTERR(1:8)=ITCH
  52. * CALL LIRABJ(ITCH,IRET,1,IRETO)
  53. * CALL QUENOM(ITCH)
  54. * MOTERR(9:16)=ITCH
  55. * CALL ERREUR(551)
  56. * RETURN
  57. 20 CONTINUE
  58. MDEOBT=MDEOBJ
  59. MFIOBT=MFIOBJ
  60. MBLPRT=MBLPRO
  61. MTXBLC=MTXBL
  62. MARM = MARGUM
  63. IF (MBLSUP.NE.0) SEGDES MTXBLC
  64. ISSPOT=ISPOTE
  65. SEGDES ISSPOT
  66. IRETCO=MOBJCO
  67. SEGDES MBLOC
  68. MTEMP=MBLOC
  69. IF (IREBLO.EQ.0) GOTO 10
  70. C
  71. C LE BLOC REPETER EXISTE DEJA
  72. C
  73. segini,mbloc=MBLO1
  74. iouep2(imablu)=mbloc
  75. SEGACT MBLOC*MOD
  76. ISSPOT=ISPOTE
  77. SEGACT ISSPOT*MOD
  78. * write(6,*) 'ispote ipotem(1) ', ispote, ipotem(1)
  79. MOBJCO=IRETCO
  80. mdecip = mdeobt - mdeobj
  81. do iou=1,ipotem(/1)
  82. ipotem(iou)=ipotem(iou)+mdecip
  83. enddo
  84. MDEOBJ=MDEOBT
  85. MFIOBJ=MFIOBT
  86. MBLPRO=MBLPRT
  87. MBLSUP=MTEMP
  88. MARGUM = MARM
  89. MTXBLC=MTXBL
  90. SEGACT MTXBLC
  91. * ILON= MTXBLC(/1)
  92. MBCOUR=0
  93. MBCONT=MBC
  94. MBFONC=0
  95. MBERR =0
  96. ICHC=NCONBO
  97. ICONBO=1
  98. IIPROU=ICONBO
  99. * write(6,*)' bloc2 repete mbloc mdeobj lmnnom',mbloc,mdeobj,lmnnom
  100. CALL NOMENT(ICHC,IIPROU)
  101. TSTMBC=(MBC.EQ.0.AND.LECTAB.EQ.0)
  102. GOTO 100
  103.  
  104. 10 CONTINUE
  105. C
  106. C ON EST EN DEFINITION D'UN NOUVEAU BLOC
  107. C
  108. NBMOT=0
  109. SEGINI MBLOC
  110. NVQTEM=20
  111. SEGINI ISSPOT
  112. ISPOTE= ISSPOT
  113. NBNOMM=1200
  114. NINST=1200
  115. IPVINN=3000
  116. SEGINI MTXBLC
  117. NINSTV=0
  118. IPVINV=0
  119. MTXBL=MTXBLC
  120. MBLSUP=MTEMP
  121. MARGUM = MARM
  122. MBCONT=MBC
  123. MBLPRO=0
  124. MBCOUR=0
  125. MBFONC=1
  126. MBERR=0
  127. MDEOBJ=MDEOBT
  128. MFIOBJ=MFIOBT
  129. MOBJCO=IRETCO
  130. * write(6,*) 'creation de bloc mblo mde lmnn',mbloc,mdeobj,lmnnom
  131. CALL NOMOBJ('BLOC ',ICHA,MBLOC)
  132. call savseg (mbloc)
  133. call savseg (ISSPOT)
  134. call savseg(MTXBLC)
  135. ICHC(1:1)='&'
  136. ICHC(2:8)=ICHA(1:7)
  137. NCONBO=ICHC
  138. ICONBO=1
  139. IIPROU=ICONBO
  140. CALL NOMENT(ICHC,IIPROU)
  141. TSTMBC=(MBC.EQ.0.AND.MDEOBJ.EQ.1.AND.LECTAB.EQ.0)
  142. *
  143. * CODE QUI PERMET DE NE PAS EXECUTER LE CONTENU DU BLOC REPETER
  144. * SI LA VALEUR INITIALE DU COMPTEUR VAUT ZERO (MBC = 0)
  145. * ATTENTION : CE CODE NE DOIT PAS ETRE EXECUTE SI L'ON EST DANS
  146. * UNE PHASE DE LECTURE GIBIANE SANS INTERPRETATION,
  147. * COMME PAR EXEMPLE LORS DU PREMIER APPEL D'UNE
  148. * PROCEDURE OU LORS DU PASSAGE DANS LA BRANCHE FAUX
  149. * D'UN BLOC SI/SINON/FINS (CELA POUR NE PAS PERTURBER
  150. * LES VERIFICATIONS SUR L'IMBRICATION DES BLOCS DEBP,
  151. * SI ET REPE FAITES DANS LES SUBROUTINES mapr, si ET
  152. * sinon)
  153. 100 CONTINUE
  154. IF (TSTMBC) THEN
  155. MBCONT=1
  156. 101 CONTINUE
  157. CALL NOUTRU
  158. LECTAB=1
  159. CALL LIRMO3(MFIN,1,IRET,0,IMOTCO)
  160. IF (IERR.NE.0) RETURN
  161. IF (IRET.EQ.0) GOTO 101
  162. CALL QUETYP(IJCH,0,IRETOU)
  163. IF (IRETOU.EQ.0) GOTO 101
  164. IF (IJCH.NE.'BLOC') GOTO 101
  165. CALL LIROBJ('BLOC',IRET,1,IRETOU)
  166. IF (MBLOC.NE.IRET) GOTO 101
  167. LECTAB=0
  168. CALL REFUS
  169. CALL FIN
  170. RETURN
  171. ENDIF
  172. *
  173. RETURN
  174. END
  175.  
  176.  
  177.  
  178.  
  179.  

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