Télécharger finpro.eso

Retour à la liste

Numérotation des lignes :

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

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