Sources Esope | Cast3M

finpro
C FINPRO    SOURCE    PV090527  24/01/09    21:15:10     11817          
      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
      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
      IF(MTRESU.NE.0) THEN
         IF (NBESC.NE.0) SEGACT,IPILOC
         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)
         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))
             IF (NBESC.NE.0) SEGACT,IPILOC
         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
         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