Télécharger finpro.eso

Retour à la liste

Numérotation des lignes :

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

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