Télécharger repete.eso

Retour à la liste

Numérotation des lignes :

  1. C REPETE SOURCE CB215821 19/11/15 21:16:06 10378
  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.  
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8 (A-H,O-Z)
  13.  
  14. -INC CCNOYAU
  15. -INC SMBLOC
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC CCPERF
  20.  
  21. INTEGER ITTIME(4)
  22. CHARACTER*(8) ICHA,INOM,ITCH
  23. c CHARACTER*(9) ICHB
  24. CHARACTER*(LONOM) ICHC,CNOM
  25. *
  26. CHARACTER*8 IJCH
  27. CHARACTER*4 MFIN(1)
  28. DIMENSION IMOTCO(1)
  29. SAVE IMOTCO
  30. DATA IMOTCO(1)/-1/
  31. DATA MFIN/'FIN '/
  32. LOGICAL TSTMBC
  33. MBC=-1
  34. CALL LIROBJ('BLOC ',MBLO1,0,IREBLO)
  35. if(IREBLO.NE.0) imablu=jpoob2(imotlu)
  36. IF(IREBLO.EQ.0) THEN
  37. CALL QUETYP(ICHA,1,IRETOU)
  38. IF(IERR.NE.0) RETURN
  39. c IF(ICHA.EQ.'MOT ') THEN
  40. c CALL LIRCHA(ICHB,1,IRETOU)
  41. c IF(ICHB(9:9).NE.' ') THEN
  42. c CALL ERREUR (315)
  43. c RETURN
  44. c ENDIF
  45. c CNOM=ICHB
  46. c ELSE
  47. CALL LIROBJ(ICHA,IRE,1,IRETOU)
  48. CALL QUENOM(CNOM)
  49. IF(CNOM(1:1).EQ.' ') THEN
  50. CALL ERREUR(315)
  51. RETURN
  52. ENDIF
  53. c ENDIF
  54. ENDIF
  55. CALL LIRENT(MBC,0,IRETOU)
  56. IF (IERR.NE.0) RETURN
  57. * TEST QUE L'INSTRUCTION EST EPUISEE - PROBLEME AVEC LA PRECOMPILATION
  58. * CALL QUETYP(ITCH,0,IRETO)
  59. * IF (IRETO.EQ.0) GOTO 20
  60. * MOTERR(1:8)=ITCH
  61. * CALL LIRABJ(ITCH,IRET,1,IRETO)
  62. * CALL QUENOM(ITCH)
  63. * MOTERR(9:16)=ITCH
  64. * CALL ERREUR(551)
  65. * RETURN
  66. * 20 CONTINUE
  67.  
  68. MDEOBT=MDEOBJ
  69. MFIOBT=MFIOBJ
  70. MBLPRT=MBLPRO
  71. MTXBLC=MTXBL
  72. MARM = MARGUM
  73. IF (MBLSUP.NE.0) SEGDES MTXBLC
  74. ISSPOT=ISPOTE
  75. SEGDES ISSPOT
  76. IRETCO=MOBJCO
  77. SEGDES MBLOC
  78. MTEMP =MBLOC
  79. IF (IREBLO.EQ.0) GOTO 10
  80. C
  81. C LE BLOC REPETER EXISTE DEJA
  82. C
  83. segini,mbloc=MBLO1
  84. iouep2(imablu)=mbloc
  85. SEGACT MBLOC*MOD
  86. ISSPOT=ISPOTE
  87. SEGACT ISSPOT*MOD
  88. * write(6,*) 'ispote ipotem(1) ', ispote, ipotem(1)
  89. MOBJCO=IRETCO
  90. mdecip = mdeobt - mdeobj
  91. do iou=1,ipotem(/1)
  92. ipotem(iou)=ipotem(iou)+mdecip
  93. enddo
  94. MDEOBJ=MDEOBT
  95. MFIOBJ=MFIOBT
  96. MBLPRO=MBLPRT
  97. MBLSUP=MTEMP
  98. MARGUM = MARM
  99. MTXBLC=MTXBL
  100. SEGACT MTXBLC
  101. * ILON= MTXBLC(/1)
  102. MBCOUR=0
  103. MBCONT=MBC
  104. MBFONC=0
  105. MBERR =0
  106.  
  107. C Gestion du SOUCI dans le BLOC (ACTUELLEMENT INUTILISE)
  108. MBSOUC=0
  109.  
  110. ICHC=NCONBO
  111. ICONBO=1
  112. IIPROU=ICONBO
  113. * write(6,*)' bloc2 repete mbloc mdeobj lmnnom',mbloc,mdeobj,lmnnom
  114. CALL NOMENT(ICHC,IIPROU)
  115. TSTMBC=(MBC.EQ.0.AND.LECTAB.EQ.0)
  116. GOTO 100
  117.  
  118. 10 CONTINUE
  119. C
  120. C ON EST EN DEFINITION D'UN NOUVEAU BLOC
  121. C
  122. SEGINI,MBLOC
  123. NVQTEM=20
  124. SEGINI ISSPOT
  125. ISPOTE= ISSPOT
  126. NBNOMM=1200
  127. NINST=1200
  128. IPVINN=3000
  129. SEGINI MTXBLC
  130. NINSTV=0
  131. MTXBL =MTXBLC
  132. MBLSUP=MTEMP
  133. MARGUM=MARM
  134. MBCONT=MBC
  135. MBLPRO=0
  136. MBCOUR=0
  137. MBFONC=1
  138. MBERR =0
  139.  
  140. C Gestion du SOUCI dans le BLOC (ACTUELLEMENT INUTILISE)
  141. MBSOUC=0
  142.  
  143. MDEOBJ=MDEOBT
  144. MFIOBJ=MFIOBT
  145. MOBJCO=IRETCO
  146. * write(6,*) 'creation de bloc mblo mde lmnn',mbloc,mdeobj,lmnnom
  147. CALL NOMOBJ('BLOC ',CNOM,MBLOC)
  148. call savseg(mbloc)
  149. call savseg(ISSPOT)
  150. call savseg(MTXBLC)
  151. ICHC(1:1)='&'
  152. ICHC(2:LONOM)=CNOM(1:LONOM-1)
  153. NCONBO=ICHC
  154. ICONBO=1
  155. IIPROU=ICONBO
  156. CALL NOMENT(ICHC,IIPROU)
  157. TSTMBC=(MBC.EQ.0 .AND. MDEOBJ.EQ.1 .AND. LECTAB.EQ.0)
  158. *
  159. * CODE QUI PERMET DE NE PAS EXECUTER LE CONTENU DU BLOC REPETER
  160. * SI LA VALEUR INITIALE DU COMPTEUR VAUT ZERO (MBC = 0)
  161. * ATTENTION : CE CODE NE DOIT PAS ETRE EXECUTE SI L'ON EST DANS
  162. * UNE PHASE DE LECTURE GIBIANE SANS INTERPRETATION,
  163. * COMME PAR EXEMPLE LORS DU PREMIER APPEL D'UNE
  164. * PROCEDURE OU LORS DU PASSAGE DANS LA BRANCHE FAUX
  165. * D'UN BLOC SI/SINON/FINS (CELA POUR NE PAS PERTURBER
  166. * LES VERIFICATIONS SUR L'IMBRICATION DES BLOCS DEBP,
  167. * SI ET REPE FAITES DANS LES SUBROUTINES mapr, si ET
  168. * sinon)
  169. 100 CONTINUE
  170.  
  171. C DEBUT Duree passee dans les boucles (Voir FINPRO pour la sortie)
  172. call timespv(ittime,oothrd)
  173. IELAPS=ITTIME(1) + ITTIME(2)
  174. ICPU =ITTIME(3) + ITTIME(4)
  175.  
  176. C Initialisation eventuelle des Duree passee dans les boucles
  177. CNOM =NCONBO(2:LONOM)
  178. IF(ITPSBO .EQ. 0)THEN
  179. NBBLOC=1
  180. NIVMAX=10
  181. SEGINI,ITPSBL
  182. C Mise dans le COMMON SMPERF
  183. ITPSBO=ITPSBL
  184. C Protection du MENAGE
  185. CALL SAVSEG(ITPSBL)
  186. NICOU =1
  187. ITPSBL.CDPROC(NBBLOC) = CNOM
  188. II =1
  189.  
  190. ELSE
  191. ITPSBL = ITPSBO
  192. SEGACT,ITPSBL*MOD
  193. NICOU =ITPSBL.NIVCOU
  194.  
  195. IF(NICOU .GT. 0)THEN
  196. C Incremente la duree de la boucle qu'on va quitter
  197. II=ITPSBL.IPRONI(NICOU)
  198. ITPSBL.DURPRO(1,II)=ITPSBL.DURPRO(1,II) +
  199. & (IELAPS - ITPSBL.TPSPRO(1,II))
  200. ITPSBL.DURPRO(2,II)=ITPSBL.DURPRO(2,II) +
  201. & (ICPU - ITPSBL.TPSPRO(2,II))
  202. ENDIF
  203.  
  204. NICOU =NICOU + 1
  205. NBBLOC=ITPSBL.NBAPRO(/1)
  206. DO II=1,NBBLOC
  207. IF(CNOM .EQ. ITPSBL.CDPROC(II)) GOTO 11
  208. ENDDO
  209. C Ajout de la boucle
  210. NBBLOC = NBBLOC + 1
  211. NIVMAX = ITPSBL.IPRONI(/1)
  212. SEGADJ,ITPSBL
  213. ITPSBL.CDPROC(NBBLOC) = CNOM
  214. II = NBBLOC
  215.  
  216. 11 CONTINUE
  217. IF(NICOU .GT. NIVMAX)THEN
  218. NIVMAX=NICOU * 2 + 10
  219. SEGADJ,ITPSBL
  220. ENDIF
  221. ENDIF
  222.  
  223. ITPSBL.NIVCOU = NICOU
  224. ITPSBL.IPRONI(NICOU)= II
  225. ITPSBL.TPSPRO(1,II) = IELAPS
  226. ITPSBL.TPSPRO(2,II) = ICPU
  227. ITPSBL.NBAPRO(II) = ITPSBL.NBAPRO(II) + 1
  228. C FIN Duree passee dans les boucles
  229.  
  230. IF (TSTMBC) THEN
  231. MBCONT=1
  232. 101 CONTINUE
  233. CALL NOUTRU
  234. LECTAB=1
  235. CALL LIRMO3(MFIN,1,IRET,0,IMOTCO)
  236. IF (IERR.NE.0) RETURN
  237. IF (IRET.EQ.0) GOTO 101
  238. CALL QUETYP(IJCH,0,IRETOU)
  239. IF (IRETOU.EQ.0) GOTO 101
  240. IF (IJCH.NE.'BLOC ') GOTO 101
  241. CALL LIROBJ('BLOC ',IRET,1,IRETOU)
  242. IF (MBLOC.NE.IRET) GOTO 101
  243. LECTAB=0
  244. CALL REFUS
  245. CALL FIN
  246. ENDIF
  247.  
  248. END
  249.  
  250.  
  251.  
  252.  
  253.  

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