Télécharger finpro.eso

Retour à la liste

Numérotation des lignes :

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

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