Télécharger finpro.eso

Retour à la liste

Numérotation des lignes :

  1. C FINPRO SOURCE CB215821 19/11/15 21:15:21 10378
  2. SUBROUTINE FINPRO
  3.  
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6.  
  7. -INC CCOPTIO
  8. -INC SMBLOC
  9. -INC CCNOYAU
  10. -INC CCASSIS
  11. -INC SMTABLE
  12. -INC CCPERF
  13.  
  14. INTEGER ITTIME(4)
  15. CHARACTER*(8) MMM
  16. CHARACTER*(LONOM) NOM1,NOMPRC,NOMPRS,VID24
  17. CHARACTER*(512) PPP
  18. LOGICAL BBV
  19.  
  20. IARGUM=MARGUM
  21. IF(IARGUM.EQ.0) THEN
  22. MOTERR=' '
  23. CALL ERREUR(154)
  24. RETURN
  25. ENDIF
  26. call ooohor(0)
  27. IRETOB=MOBJCO
  28. CALL RESPRO
  29. SEGACT IARGUM*MOD
  30. * MSAPI3=MSAPII
  31. * SEGACT MSAPI3
  32. * DO 5 J=1,MSAPIJ(/1)
  33. * INOOB1(MDEOBJ-1+J)=MSAPIJ(J)
  34. ** INOOB2(MDEOBJ-1+J)=MSAPIL(J)
  35. * IF(MSAPIL(J).NE.'FLOTTANT'.OR.MSAPIJ(J).NE.1)
  36. * $ IOUEP2(MDEOBJ-1+J)=MSAPIN(J)
  37. * 5 CONTINUE
  38. * SEGSUP MSAPI3
  39.  
  40. C DEBUT Duree passee dans les procedures (Voir PROCED pour le depart)
  41. call timespv(ittime,oothrd)
  42. IELAPS=ITTIME(1) + ITTIME(2)
  43. ICPU =ITTIME(3) + ITTIME(4)
  44.  
  45. ITPSBL=ITPSPR
  46. SEGACT,ITPSBL*MOD
  47.  
  48. C Niveau, position dans le tableau et nom de la procedure courante
  49. NICOU = ITPSBL.NIVCOU
  50. II = ITPSBL.IPRONI(NICOU)
  51. NOMPRC = ITPSBL.CDPROC(II)
  52.  
  53. C Incremente la duree de la procedure quittee
  54. ITPSBL.DURPRO(1,II)=ITPSBL.DURPRO(1,II) +
  55. & (IELAPS - ITPSBL.TPSPRO(1,II))
  56. ITPSBL.DURPRO(2,II)=ITPSBL.DURPRO(2,II) +
  57. & (ICPU - ITPSBL.TPSPRO(2,II))
  58.  
  59. C Remise a zero du CHRONOMETRE de la procedure parent
  60. NICOU = NICOU - 1
  61. ITPSBL.NIVCOU = NICOU
  62. IF(NICOU .GT. 0)THEN
  63. II=ITPSBL.IPRONI(NICOU)
  64. ITPSBL.TPSPRO(1,II) = IELAPS
  65. ITPSBL.TPSPRO(2,II) = ICPU
  66. ENDIF
  67. C FIN Duree passee dans les procedures
  68.  
  69. C
  70. C CHANGEMENT DE BLOC, RETOUR AU PRECEDENTE
  71. C
  72. C Gestion du SOUCI dans le BLOC (COMMENTE ACTUELLEMENT)
  73. C mbsou=mbsouc
  74.  
  75. MTXBLC=MTXBL
  76. IF(MTXBL.NE.0) SEGDES,MTXBLC
  77. MBIR =MBERR
  78. ISSPOT=ISPOTE
  79. SEGSUP ISSPOT
  80. lmnanc=lmnnom
  81. lmnnom=mdeobj-1
  82.  
  83. * OPTI 'LOCA' = VRAI (partie 1)
  84. * =========================
  85. IF (ZLOPRO) THEN
  86. * on sauvegarde dans une table les objets de la partie de la pile
  87. * globale qui est dediee a la procedure courante
  88. M = LMNANC - LMNNOM
  89. SEGINI MTAB1
  90. MTAB1.MLOTAB=M
  91. NOBJ=0
  92. IF(NBESC.NE.0) SEGACT IPILOC
  93. DO 20 I=LMNNOM+1,LMNANC
  94. IP=INOOB1(I)
  95. IDEBCH=IPCHAR(IP)
  96. IFINCH=IPCHAR(IP+1)-1
  97. NOM1=ICHARA(IDEBCH:IFINCH)
  98. * on va quand meme eliminer certains des objets dont le nom,
  99. * le type et/ou la valeur ne nous plaisent pas...
  100. IF (NOM1 .EQ.' ' ) GOTO 21
  101. IF (NOM1(1:1).EQ.'#' ) GOTO 21
  102. IF (NOM1 .EQ.'FINP' ) GOTO 21
  103. IF (INOOB2(I).EQ.'PROCEDUR') GOTO 21
  104. GOTO 22
  105. 21 CONTINUE
  106. INOOB1(I)=0
  107. INOOB2(I)=' '
  108. IOUEP2(I)=0
  109. GOTO 20
  110. 22 CONTINUE
  111. NOBJ=NOBJ+1
  112. MTAB1.MTABTI(NOBJ) ='MOT '
  113. MTAB1.MTABII(NOBJ) = INOOB1(I)
  114. MTAB1.MTABTV(NOBJ) = INOOB2(I)
  115. IF (INOOB2(I).EQ.'FLOTTANT') THEN
  116. MTAB1.RMTABV(NOBJ)=XIFLOT(IOUEP2(I))
  117. ELSE
  118. MTAB1.MTABIV(NOBJ)=IOUEP2(I)
  119. ENDIF
  120. 20 CONTINUE
  121. IF (NBESC.NE.0) SEGDES,IPILOC
  122.  
  123. M=NOBJ
  124. MTAB1.MLOTAB = M
  125. SEGADJ,MTAB1
  126.  
  127. * OPTI 'LOCA' = FAUX
  128. * ==================
  129. ELSE
  130.  
  131. * on efface la partie de la pile qui etait affectée à la procedure
  132. DO IAZ=LMNNOM+1,LMNANC
  133. INOOB1(IAZ)=0
  134. INOOB2(IAZ)=' '
  135. IOUEP2(IAZ)=0
  136. ENDDO
  137. ENDIF
  138.  
  139.  
  140. * ON RECHARGE LE BLOC PARENT
  141. * write(6,*) ' finpro lmnnom' , lmnnom
  142. MBLO1 =MBLSUP
  143. SEGSUP,MBLOC
  144.  
  145. MBLOC=MBLO1
  146. SEGACT MBLOC*MOD
  147.  
  148. C Gestion du SOUCI dans le BLOC (COMMENTE ACTUELLEMENT)
  149. C mbsouc=max(mbsou,mbsouc)
  150.  
  151. ISSPOT=ISPOTE
  152. SEGACT ISSPOT*MOD
  153. MBERR=MBIR
  154. MTXBLC=MTXBL
  155. IF(MTXBL.NE.0) SEGACT MTXBLC
  156. CALL PROCRE
  157.  
  158.  
  159. * OPTI 'LOCA' = VRAI (partie 2)
  160. * ==================
  161. IF (ZLOPRO) THEN
  162. NOM1(1:1)='&'
  163. NOM1(2:LONOM)=NOMPRC(1:LONOM-1)
  164. CALL NOMOBJ('TABLE ',NOM1,MTAB1)
  165. ENDIF
  166.  
  167. C
  168. C ECRITURE DES RESULTAS DANS LA PILE DES OBJETS LUS
  169. C
  170. MTRESU=ITRESU
  171. IF(MTRESU.NE.0) THEN
  172. IF (NBESC.NE.0) SEGACT,IPILOC
  173. SEGACT,MTRESU
  174. IF(IIMPI.EQ.1754) WRITE(IOIMP,*)' DANS FINPRO NRESI ',NRESI
  175. IF(NRESI.NE.0.AND.MBIR.EQ.0) THEN
  176. DO 2 ILERT=1,NRESI
  177. I = NRESI - ILERT + 1
  178. MMM=MTYRES(I)
  179. IIP=IVARES(I)
  180. IF(MMM.EQ.'ENTIER ') THEN
  181. IIV=IIP
  182. CALL ECRENT(IIV)
  183. ELSEIF(MMM.EQ.'FLOTTANT')THEN
  184. XXA=XFLRES(I)
  185. CALL ECRREE(XXA)
  186. ELSEIF(MMM.EQ.'MOT ') THEN
  187. IIC=IPCHAR(IIP)
  188. IID=IPCHAR(IIP+1)
  189. PPP=' '
  190. PPP(1:IID-IIC)=ICHARA(IIC:IID-1)
  191. CALL ECRCHA(PPP(1:IID-IIC))
  192. IF (NBESC.NE.0) SEGACT,IPILOC
  193. ELSEIF(MMM.EQ.'LOGIQUE ') THEN
  194. BBV=IPLOGI(IIP)
  195. CALL ECRLOG(BBV)
  196. ELSEIF(MMM.EQ.'METHODOL') THEN
  197. * write(6,*) ' finpro iretob',iretob
  198. CALL ECROBJ('OBJET ',IRETOB)
  199. ELSE
  200. CALL ECROBJ(MMM,IIP)
  201. ENDIF
  202. 2 CONTINUE
  203.  
  204. IF (NBESC.NE.0) SEGDES,IPILOC
  205. SEGSUP MTRESU
  206. ENDIF
  207.  
  208. ENDIF
  209. ITRESU=0
  210. SEGDES,IARGUM
  211. LECTAB=1
  212. * write(6,*)'sortie de finpro lmnnom mbloc ' ,lmnnom, mbloc
  213. * write(6,*)'nbnom mbcour ipvir intemp',nbnom,mbcour,ipvir,intemp
  214.  
  215. END
  216.  
  217.  
  218.  

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