Télécharger la plaquette Cast3M


fr en

Télécharger finpro.eso

Retour à la liste

Numérotation des lignes : 

finpro

  1. C FINPRO    SOURCE    CB215821  24/07/17    21:15:06     11961          
  2.       SUBROUTINE FINPRO
  3.  
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.  
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMBLOC
  11. -INC CCNOYAU
  12. -INC CCASSIS
  13. -INC SMTABLE
  14. -INC CCPERF
  15.  
  16.       INTEGER           ITTIME(4)
  17.       CHARACTER*(8)     MMM
  18.       CHARACTER*(LONOM) NOM1,NOMPRC,NOMPRS,VID24
  19.       CHARACTER*(512)   PPP
  20.       LOGICAL BBV
  21.  
  22.       IARGUM=MARGUM
  23.       IF(IARGUM.EQ.0) THEN
  24.         MOTERR=' '
  25.         CALL ERREUR(154)
  26.         RETURN
  27.       ENDIF
  28.       call ooohor(0)
  29.       IRETOB=MOBJCO
  30.       CALL RESPRO
  31.       SEGACT IARGUM*MOD
  32. *      MSAPI3=MSAPII
  33. *      SEGACT MSAPI3
  34. *      DO 5 J=1,MSAPIJ(/1)
  35. *      INOOB1(MDEOBJ-1+J)=MSAPIJ(J)
  36. **      INOOB2(MDEOBJ-1+J)=MSAPIL(J)
  37. *      IF(MSAPIL(J).NE.'FLOTTANT'.OR.MSAPIJ(J).NE.1)
  38. *     $ IOUEP2(MDEOBJ-1+J)=MSAPIN(J)
  39. *   5  CONTINUE
  40. *      SEGSUP MSAPI3
  41.  
  42. C     DEBUT Duree passee dans les procedures (Voir PROCED pour le depart)
  43.       call timespv(ittime,oothrd)
  44.       IELAPS=ITTIME(1) + ITTIME(2)
  45.       ICPU  =ITTIME(3) + ITTIME(4)
  46.  
  47.       ITPSBL=ITPSPR
  48.       SEGACT,ITPSBL*MOD
  49.  
  50. C     Niveau, position dans le tableau et nom de la procedure courante
  51.       NICOU  = ITPSBL.NIVCOU
  52.       II     = ITPSBL.IPRONI(NICOU)
  53.       NOMPRC = ITPSBL.CDPROC(II)
  54.  
  55. C     Incremente la duree de la procedure quittee
  56.       ITPSBL.DURPRO(1,II)=ITPSBL.DURPRO(1,II) +
  57.      &                   (IELAPS - ITPSBL.TPSPRO(1,II))
  58.       ITPSBL.DURPRO(2,II)=ITPSBL.DURPRO(2,II) +
  59.      &                   (ICPU   - ITPSBL.TPSPRO(2,II))
  60.  
  61. C     Remise a zero du CHRONOMETRE de la procedure parent
  62.       NICOU = NICOU - 1
  63.       ITPSBL.NIVCOU = NICOU
  64.       IF(NICOU .GT. 0)THEN
  65.         II=ITPSBL.IPRONI(NICOU)
  66.         ITPSBL.TPSPRO(1,II) = IELAPS
  67.         ITPSBL.TPSPRO(2,II) = ICPU
  68.       ENDIF
  69. C     FIN Duree passee dans les procedures
  70.  
  71. C
  72. C  CHANGEMENT DE BLOC, RETOUR AU PRECEDENTE
  73. C
  74. C     Gestion du SOUCI dans le BLOC (COMMENTE ACTUELLEMENT)
  75. C     mbsou=mbsouc
  76.  
  77.       MTXBLC=MTXBL
  78.       IF(MTXBL.NE.0) SEGDES,MTXBLC
  79.       MBIR  =MBERR
  80.       ISSPOT=ISPOTE
  81.       SEGSUP ISSPOT
  82.       lmnanc=lmnnom
  83.       lmnnom=mdeobj-1
  84.  
  85. *     OPTI 'LOCA' = VRAI (partie 1)
  86. *     =========================
  87.       IF (ZLOPRO) THEN
  88. *       on sauvegarde dans une table les objets de la partie de la pile
  89. *       globale qui est dediee a la procedure courante
  90.         M = LMNANC - LMNNOM
  91.         SEGINI MTAB1
  92.         MTAB1.MLOTAB=M
  93.         NOBJ=0
  94.         IF(NBESC.NE.0) SEGACT IPILOC
  95.         DO 20 I=LMNNOM+1,LMNANC
  96.           IP=INOOB1(I)
  97.           IDEBCH=IPCHAR(IP)
  98.           IFINCH=IPCHAR(IP+1)-1
  99.           NOM1=ICHARA(IDEBCH:IFINCH)
  100. *         on va quand meme eliminer certains des objets dont le nom,
  101. *         le type et/ou la valeur ne nous plaisent pas...
  102.           IF (NOM1     .EQ.' '       ) GOTO 21
  103.           IF (NOM1(1:1).EQ.'#'       ) GOTO 21
  104.           IF (NOM1     .EQ.'FINP'    ) GOTO 21
  105.           IF (INOOB2(I).EQ.'PROCEDUR') GOTO 21
  106.           GOTO 22
  107.   21      CONTINUE
  108.           INOOB1(I)=0
  109.           INOOB2(I)=' '
  110.           IOUEP2(I)=0
  111.           GOTO 20
  112.   22      CONTINUE
  113.           NOBJ=NOBJ+1
  114.           MTAB1.MTABTI(NOBJ) ='MOT     '
  115.           MTAB1.MTABII(NOBJ) = INOOB1(I)
  116.           MTAB1.MTABTV(NOBJ) = INOOB2(I)
  117.           IF (INOOB2(I).EQ.'FLOTTANT') THEN
  118.             MTAB1.RMTABV(NOBJ)=XIFLOT(IOUEP2(I))
  119.           ELSE
  120.             MTAB1.MTABIV(NOBJ)=IOUEP2(I)
  121.           ENDIF
  122.   20    CONTINUE
  123.         IF (NBESC.NE.0) SEGDES,IPILOC
  124.  
  125.         M=NOBJ
  126.         MTAB1.MLOTAB = M
  127.         SEGADJ,MTAB1
  128.  
  129. *     OPTI 'LOCA' = FAUX
  130. *     ==================
  131.       ELSE
  132.  
  133. *       on efface la partie de la pile qui etait affectée à la procedure
  134.         DO IAZ=LMNNOM+1,LMNANC
  135.           INOOB1(IAZ)=0
  136.           INOOB2(IAZ)=' '
  137.           IOUEP2(IAZ)=0
  138.         ENDDO
  139.       ENDIF
  140.  
  141.  
  142. *     ON RECHARGE LE BLOC PARENT
  143. *      write(6,*) ' finpro lmnnom' , lmnnom
  144.       MBLO1 =MBLSUP
  145. **    write(6,*) 'finpro ancien mbloc itresu',mbloc,itresu
  146.       mtresu = itresu
  147.       SEGSUP,MBLOC
  148.  
  149.       MBLOC=MBLO1
  150.       SEGACT MBLOC*MOD
  151.  
  152. C     Gestion du SOUCI dans le BLOC (COMMENTE ACTUELLEMENT)
  153. C     mbsouc=max(mbsou,mbsouc)
  154.  
  155.       ISSPOT=ISPOTE
  156.       SEGACT ISSPOT*MOD
  157.       MBERR=MBIR
  158.       MTXBLC=MTXBL
  159.       IF(MTXBL.NE.0) SEGACT MTXBLC
  160.       CALL PROCRE
  161.  
  162.  
  163. *     OPTI 'LOCA' = VRAI (partie 2)
  164. *     ==================
  165.       IF (ZLOPRO) THEN
  166.         NOM1(1:1)='&'
  167.         NOM1(2:LONOM)=NOMPRC(1:LONOM-1)
  168.         CALL NOMOBJ('TABLE   ',NOM1,MTAB1)
  169.       ENDIF
  170.  
  171. C
  172. C  ECRITURE DES RESULTAS DANS LA PILE DES OBJETS LUS
  173. C
  174. *     MTRESU=ITRESU
  175. **    write (6,*) 'finpro mbloc mtresu',mbloc,mtresu
  176.       IF(MTRESU.NE.0) THEN
  177.          IF (NBESC.NE.0) SEGACT,IPILOC
  178.          SEGACT,MTRESU
  179.          IF(IIMPI.EQ.1754) WRITE(IOIMP,*)'  DANS FINPRO NRESI ',NRESI
  180.          IF(NRESI.NE.0.AND.MBIR.EQ.0) THEN
  181.          DO 2 ILERT=1,NRESI
  182.          I = NRESI - ILERT + 1
  183.          MMM=MTYRES(I)
  184.          IIP=IVARES(I)
  185.          IF(MMM.EQ.'ENTIER  ') THEN
  186.             IIV=IIP
  187.             CALL ECRENT(IIV)
  188.          ELSEIF(MMM.EQ.'FLOTTANT')THEN
  189.             XXA=XFLRES(I)
  190.             CALL ECRREE(XXA)
  191.          ELSEIF(MMM.EQ.'MOT     ')  THEN
  192.              IIC=IPCHAR(IIP)
  193.              IID=IPCHAR(IIP+1)
  194.              PPP=' '
  195.              PPP(1:IID-IIC)=ICHARA(IIC:IID-1)
  196.              CALL ECRCHA(PPP(1:IID-IIC))
  197.              IF (NBESC.NE.0) SEGACT,IPILOC
  198.          ELSEIF(MMM.EQ.'LOGIQUE ') THEN
  199.             BBV=IPLOGI(IIP)
  200.             CALL ECRLOG(BBV)
  201.          ELSEIF(MMM.EQ.'METHODOL')  THEN
  202. *            write(6,*) ' finpro   iretob',iretob
  203.             CALL ECROBJ('OBJET   ',IRETOB)
  204.          ELSE
  205.             CALL ECROBJ(MMM,IIP)
  206.          ENDIF
  207.    2     CONTINUE
  208.  
  209.          IF (NBESC.NE.0) SEGDES,IPILOC
  210. **       write(6,*) 'finpro iargum tresu supprime',iargum,mtresu
  211.          SEGSUP MTRESU
  212.       ENDIF
  213.  
  214.       ENDIF
  215. **    ITRESU=0
  216.       SEGDES,IARGUM
  217.       LECTAB=1
  219. *      write(6,*)'sortie de finpro lmnnom  mbloc ' ,lmnnom, mbloc
  220. *      write(6,*)'nbnom mbcour ipvir intemp',nbnom,mbcour,ipvir,intemp
  221.  
  222.       END
  223.  
  224.  
  225.  
  226.  
  227.  

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