C FINPRO    SOURCE    GOUNAND   25/07/10    21:15:02     12312          
      SUBROUTINE FINPRO

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC SMBLOC
-INC CCNOYAU
-INC CCASSIS
-INC SMTABLE
-INC CCPERF

      INTEGER           ITTIME(4)
      CHARACTER*(8)     MMM
      CHARACTER*(LONOM) NOM1,NOMPRC,NOMPRS,VID24
      CHARACTER*(512)   PPP
      LOGICAL BBV

      IARGUM=MARGUM
      IF(IARGUM.EQ.0) THEN
        MOTERR=' '
        CALL ERREUR(154)
        RETURN
      ENDIF
      call ooohor(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     DEBUT Duree passee dans les procedures (Voir PROCED pour le depart)
      call timespv(ittime,oothrd)
      IELAPS=ITTIME(1) + ITTIME(2)
      ICPU  =ITTIME(3) + ITTIME(4)

      ITPSBL=ITPSPR
      SEGACT,ITPSBL*MOD

C     Niveau, position dans le tableau et nom de la procedure courante
      NICOU  = ITPSBL.NIVCOU
      II     = ITPSBL.IPRONI(NICOU)
      NOMPRC = ITPSBL.CDPROC(II)

C     Incremente la duree de la procedure quittee
      ITPSBL.DURPRO(1,II)=ITPSBL.DURPRO(1,II) +
     &                   (IELAPS - ITPSBL.TPSPRO(1,II))
      ITPSBL.DURPRO(2,II)=ITPSBL.DURPRO(2,II) +
     &                   (ICPU   - ITPSBL.TPSPRO(2,II))

C     Remise a zero du CHRONOMETRE de la procedure parent
      NICOU = NICOU - 1
      ITPSBL.NIVCOU = NICOU
      IF(NICOU .GT. 0)THEN
        II=ITPSBL.IPRONI(NICOU)
        ITPSBL.TPSPRO(1,II) = IELAPS
        ITPSBL.TPSPRO(2,II) = ICPU
      ENDIF
C     FIN Duree passee dans les procedures

C
C  CHANGEMENT DE BLOC, RETOUR AU PRECEDENTE
C
C     Gestion du SOUCI dans le BLOC (COMMENTE ACTUELLEMENT)
C     mbsou=mbsouc

      MTXBLC=MTXBL
      IF(MTXBL.NE.0) SEGDES,MTXBLC
      MBIR  =MBERR
      ISSPOT=ISPOTE
      SEGSUP ISSPOT
      lmnanc=lmnnom
      lmnnom=mdeobj-1

*     OPTI 'LOCA' = VRAI (partie 1)
*     =========================
      IF (ZLOPRO) THEN
*       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
        IF(NBESC.NE.0) SEGACT IPILOC
        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
            MTAB1.RMTABV(NOBJ)=XIFLOT(IOUEP2(I))
          ELSE
            MTAB1.MTABIV(NOBJ)=IOUEP2(I)
          ENDIF
  20    CONTINUE
        IF (NBESC.NE.0) SEGDES,IPILOC

        M=NOBJ
        MTAB1.MLOTAB = M
        SEGADJ,MTAB1

*     OPTI 'LOCA' = FAUX
*     ==================
      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
      MBLO1 =MBLSUP
**    write(6,*) 'finpro ancien mbloc itresu',mbloc,itresu
      mtresu = itresu
      SEGSUP,MBLOC

      MBLOC=MBLO1
      SEGACT MBLOC*MOD

C     Gestion du SOUCI dans le BLOC (COMMENTE ACTUELLEMENT)
C     mbsouc=max(mbsou,mbsouc)

      ISSPOT=ISPOTE
      SEGACT ISSPOT*MOD
      MBERR=MBIR
      MTXBLC=MTXBL
      IF(MTXBL.NE.0) SEGACT MTXBLC
      CALL PROCRE


*     OPTI 'LOCA' = VRAI (partie 2)
*     ==================
      IF (ZLOPRO) THEN
        NOM1(1:1)='&'
        NOM1(2:LONOM)=NOMPRC(1:LONOM-1)
        CALL NOMOBJ('TABLE   ',NOM1,MTAB1)
      ENDIF

C
C  ECRITURE DES RESULTAS DANS LA PILE DES OBJETS LUS
C
*     MTRESU=ITRESU
**    write (6,*) 'finpro mbloc mtresu',mbloc,mtresu
      IF(MTRESU.NE.0) THEN
         SEGACT,MTRESU
         IF(IIMPI.EQ.1754) WRITE(IOIMP,*)'  DANS FINPRO NRESI ',NRESI
         IF(NRESI.NE.0.AND.MBIR.EQ.0) THEN
         DO 2 ILERT=1,NRESI
            I = NRESI - ILERT + 1
            MMM=MTYRES(I)
            IIP=IVARES(I)
*            CALL OOOETA(IPILOC,IETA,IMOD)
*         WRITE(IOIMP,*) 'FINPRO ILERT I=',I,' MMM=',MMM,' IETA=',IETA
*     $        ,' NBESC=',NBESC
            IF(MMM.EQ.'ENTIER  ') THEN
               IIV=IIP
               CALL ECRENT(IIV)
            ELSEIF(MMM.EQ.'FLOTTANT')THEN
               IF (NBESC.NE.0) SEGACT,IPILOC
               XXA=XFLRES(I)
               CALL ECRREE(XXA)
            ELSEIF(MMM.EQ.'MOT     ')  THEN
               IF (NBESC.NE.0) SEGACT,IPILOC
               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
               IF (NBESC.NE.0) SEGACT,IPILOC
               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
**       write(6,*) 'finpro iargum tresu supprime',iargum,mtresu
         SEGSUP MTRESU
      ENDIF

      ENDIF
**    ITRESU=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
      END