C FINPRO SOURCE JC220346 13/12/17 21:15:05 7885 SUBROUTINE FINPRO IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCOPTIO -INC SMBLOC -INC CCNOYAU -INC CCASSIS -INC SMTABLE CHARACTER*(8) MMM,NOM1,NOMPRC CHARACTER*(72) PPP LOGICAL BBV IARGUM=MARGUM IF(IARGUM.EQ.0) THEN CALL ERREUR (154) RETURN ENDIF call ooohor(0,0) IRETOB=MOBJCO CALL RESPRO SEGACT IARGUM*MOD * MSAPI3=MSAPII * SEGACT MSAPI3 * DO 5 J=1,MSAPIJ(/1) * INOOB1(MDEOBJ-1+J)=MSAPIJ(J) ** INOOB2(MDEOBJ-1+J)=MSAPIL(J) * IF(MSAPIL(J).NE.'FLOTTANT'.OR.MSAPIJ(J).NE.1) * $ IOUEP2(MDEOBJ-1+J)=MSAPIN(J) * 5 CONTINUE * SEGSUP MSAPI3 C C CHANGEMENT DE BLOC, RETOUR AU PRECEDENTE C MTEM=MBLSUP MTXBLC=MTXBL IF(MTXBL.NE.0) SEGDES MTXBLC MBIR=MBERR ISSPOT=ISPOTE SEGSUP ISSPOT lmnanc=lmnnom lmnnom=mdeobj-1 * OPTI 'PROC' 'SAUV' (partie 1) * ================== IF (ZLOPRO) THEN IF(NBESC.NE.0) SEGACT IPILOC * on cherche le nom de la procedure courante dans la pile globale * (partie anterieure a la procedure) NOMPRC = ' ' DO 10 I=1,LMNNOM IF (INOOB1(I).EQ.1) GOTO 10 IF (INOOB2(I).NE.'PROCEDUR') GOTO 10 IF (IPIPR1(IOUEP2(I)).NE.MBLPRO) GOTO 10 IP=INOOB1(I) IDEBCH=IPCHAR(IP) IFINCH=IPCHAR(IP+1)-1 NOMPRC=ICHARA(IDEBCH:IFINCH) GOTO 11 10 CONTINUE CALL ERREUR(5) RETURN 11 CONTINUE * on sauvegarde dans une table les objets de la partie de la pile * globale qui est dediee a la procedure courante M = LMNANC - LMNNOM SEGINI MTAB1 MTAB1.MLOTAB=M NOBJ=0 DO 20 I=LMNNOM+1,LMNANC IP=INOOB1(I) IDEBCH=IPCHAR(IP) IFINCH=IPCHAR(IP+1)-1 NOM1=ICHARA(IDEBCH:IFINCH) * on va quand meme eliminer certains des objets dont le nom, * le type et/ou la valeur ne nous plaisent pas... IF (NOM1.EQ.' ') GOTO 21 IF (NOM1(1:1).EQ.'#') GOTO 21 IF (NOM1.EQ.'FINP') GOTO 21 IF (INOOB2(I).EQ.'PROCEDUR') GOTO 21 GOTO 22 21 CONTINUE INOOB1(I)=0 INOOB2(I)=' ' IOUEP2(I)=0 GOTO 20 22 CONTINUE NOBJ=NOBJ+1 MTAB1.MTABTI(NOBJ) = 'MOT ' MTAB1.MTABII(NOBJ) = INOOB1(I) MTAB1.MTABTV(NOBJ) = INOOB2(I) IF (INOOB2(I).EQ.'FLOTTANT') THEN IF (NBESC.NE.0) SEGACT,IPILOC MTAB1.RMTABV(NOBJ)=XIFLOT(IOUEP2(I)) IF (NBESC.NE.0) SEGDES,IPILOC ELSE MTAB1.MTABIV(NOBJ)=IOUEP2(I) ENDIF 20 CONTINUE M=NOBJ MTAB1.MLOTAB = M SEGADJ,MTAB1 * OPTI 'PROC' 'OUBL' * ================== ELSE * on efface la partie de la pile qui etait affectée à la procedure DO IAZ=LMNNOM+1,LMNANC INOOB1(IAZ)=0 INOOB2(IAZ)=' ' IOUEP2(IAZ)=0 ENDDO ENDIF * ON RECHARGE LE BLOC PARENT * write(6,*) ' finpro lmnnom' , lmnnom SEGSUP MBLOC MBLOC=MTEM SEGACT MBLOC*MOD ISSPOT=ISPOTE SEGACT ISSPOT*MOD MBERR=MBIR MTXBLC=MTXBL IF(MTXBL.NE.0) SEGACT MTXBLC CALL PROCRE * OPTI 'PROC' 'SAUV' (partie 2) * ================== IF (ZLOPRO) THEN NOM1(1:1)='&' NOM1(2:8)=NOMPRC(1:7) IF(NBESC.NE.0) SEGDES IPILOC CALL NOMOBJ('TABLE ',NOM1,MTAB1) ENDIF C C ECRITURE DES RESULTAS DANS LA PILE DES OBJETS LUS C MTRESU=ITRESU MVRESU=IVRESU MFRESU=IFRESU IF(MTRESU.NE.0) THEN SEGACT MTRESU,MVRESU,MFRESU NRES = IVARES(/1) IF(IIMPI.EQ.1754) WRITE(IOIMP,*)' DANS FINPRO NRES ',NRES IF(NRES.NE.0.AND.MBIR.EQ.0) THEN DO 2 ILERT=1,NRES if(nbesc.ne.0) segact ipiloc I = NRES - ILERT + 1 MMM=MTYRES(I) IIP=IVARES(I) IF(MMM.EQ.'ENTIER ') THEN IIV=IIP CALL ECRENT(IIV) ELSEIF(MMM.EQ.'FLOTTANT')THEN XXA=XFLRES(I) CALL ECRREE(XXA) ELSEIF(MMM.EQ.'MOT ') THEN IIC=IPCHAR(IIP) IID=IPCHAR(IIP+1) PPP=' ' PPP(1:IID-IIC)=ICHARA(IIC:IID-1) CALL ECRCHA(PPP(1:IID-IIC)) ELSEIF(MMM.EQ.'LOGIQUE ') THEN BBV=IPLOGI(IIP) CALL ECRLOG(BBV) ELSEIF(MMM.EQ.'METHODOL') THEN * write(6,*) ' finpro iretob',iretob CALL ECROBJ('OBJET ',IRETOB) ELSE CALL ECROBJ(MMM,IIP) ENDIF 2 CONTINUE if(nbesc.ne.0) segdes ipiloc ENDIF SEGSUP MTRESU,MVRESU,MFRESU ENDIF ITRESU=0 IVRESU=0 IFRESU=0 SEGDES IARGUM LECTAB=1 INTEXT=1 * write(6,*)'sortie de finpro lmnnom mbloc ' ,lmnnom, mbloc * write(6,*)'nbnom mbcour ipvir intemp',nbnom,mbcour,ipvir,intemp RETURN END