Télécharger la plaquette Cast3M


fr en

Télécharger repete.eso

Retour à la liste

Numérotation des lignes : 

repete

  1. C REPETE    SOURCE    CB215821  24/07/17    21:15:17     11961          
  2. C  CET OPERATEUR INITIALISE LA FONCTION REPETER DE GIBIANE
  3. C  IL DOIT ETRE SUIVI DU NOM D'UN BLOC REPETER
  4. C  SI CE BLOC EXISTE LIRNOM EST DEROUTE POUR LE LIRE
  5. C  SI CE BLOC N'EXISTE PAS IL LE CREE ET LIRNOM LE REMPLIT
  6. C  A LA PREMIERE INTERPRETATION
  7. C  LE BLOC FINI PAR FIN "BLOC"
  8. C  icle indique si on est appele par pilot ou non
  9. C
  10.       SUBROUTINE REPETE(icle)
  11.  
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8 (A-H,O-Z)
  14.  
  15. -INC CCNOYAU
  16. -INC SMBLOC
  17. -INC SMLOBJE
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC CCPERF
  22.  
  23.       INTEGER ITTIME(4)
  24.       CHARACTER*(8)     ICHA,INOM,ITCH
  25. c     CHARACTER*(9)     ICHB
  26.       CHARACTER*(LONOM) ICHC,CNOM
  27. *
  28.       CHARACTER*8 IJCH
  29.       CHARACTER*4 MFIN(1)
  30.       DIMENSION IMOTCO(1)
  31.       SAVE IMOTCO
  32.       DATA IMOTCO(1)/-1/
  33.       DATA MFIN/'FIN '/
  34.       LOGICAL TSTMBC
  35.       MBC=-1
  36.       mblo=-1
  37.       mlobje=0
  38.       CALL LIROBJ('BLOC    ',MBLO1,0,IREBLO)
  39.       IF(IERR.NE.0) RETURN
  40.  
  41.       if(IREBLO.NE.0)   then
  42.         imablu=jpoob2(imotlu)
  43.         segact mblo1
  44.         if (mblo1.mberr.ne.0) call erreur (1143)
  45.       endif
  46.       IF(IREBLO.EQ.0)  THEN
  47.             icha=' '
  48.             CALL LIROBJ(ICHA,IRE,1,IRETOU)
  49.             IF(IERR.NE.0) RETURN
  50.             CALL QUENOM(CNOM)
  51.             IF(IERR.NE.0) RETURN
  52.             IF(CNOM(1:1).EQ.' ') THEN
  53.               CALL ERREUR(315)
  54.               RETURN
  55.             ENDIF
  56. c          ENDIF
  57.       ENDIF
  58. *  lecture eventuelle d'un listobje
  59.       if (icle.eq.0) then
  60.       mlobje=0
  61.       call lirobj('LISTOBJE',mlobje,0,iretol)
  62.       if(mlobje.ne.0) then
  63.         segact mlobje
  64.         mbc=lisobj(/1)
  65.       endif
  66.       endif
  67.       if(mbc.eq.-1)  CALL LIRENT(MBC,0,IRETOe)
  68.       IF (IERR.NE.0) RETURN
  69. *  TEST QUE L'INSTRUCTION EST EPUISEE - PROBLEME AVEC LA PRECOMPILATION
  70.       if(icle.eq.0) then
  71.       ITCH=' '
  72.       CALL LIROBJ(ITCH,IRET,0,IRETO)
  73.       if(ireto.ne.0)  then
  74.       MOTERR(1:8)=ITCH
  75.       CALL ERREUR(39)
  76.       RETURN
  77.       endif
  78.       endif
  79. *  20 CONTINUE
  80.  
  81.       MDEOBT=MDEOBJ
  82.       MFIOBT=MFIOBJ
  83.       MBLPRT=MBLPRO
  84.       MTXBLC=MTXBL
  85.       MARM = MARGUM
  86.       IF (MBLSUP.NE.0) SEGDES MTXBLC
  87.       ISSPOT=ISPOTE
  88.       SEGDES ISSPOT
  89.       IRETCO=MOBJCO
  90.       SEGDES MBLOC
  91.       MTEMP =MBLOC
  92.       IF (IREBLO.EQ.0) GOTO 10
  93. C
  94. C  LE BLOC REPETER EXISTE DEJA
  95. C
  96.       segini,mbloc=MBLO1
  97.       iouep2(imablu)=mbloc
  98.       SEGACT MBLOC*MOD
  99.       ISSPOT=ISPOTE
  100.       SEGACT ISSPOT*MOD
  101. *      write(6,*) 'ispote ipotem(1) ', ispote, ipotem(1)
  102.       MOBJCO=IRETCO
  103.       mdecip = mdeobt  - mdeobj
  104.       do iou=1,ipotem(/1)
  105.         ipotem(iou)=ipotem(iou)+mdecip
  106.       enddo
  107.       MDEOBJ=MDEOBT
  108.       MFIOBJ=MFIOBT
  109.       MBLPRO=MBLPRT
  110.       MBLSUP=MTEMP
  111.       MARGUM = MARM
  112.       MTXBLC=MTXBL
  113.       SEGACT MTXBLC
  114. *      ILON= MTXBLC(/1)
  115.       MBCOUR=0
  116.       MBCONT=MBC
  117.       MBFONC=0
  118.       MBERR =0
  119.  
  120. C     Gestion du SOUCI dans le BLOC (ACTUELLEMENT INUTILISE)
  121.       MBSOUC=0
  122.  
  123.       ICHC=NCONBO
  124.       ICONBO=1
  125.       IIPROU=ICONBO
  126. *      write(6,*)' bloc2 repete mbloc mdeobj lmnnom',mbloc,mdeobj,lmnnom
  127.  
  128.       if(mlobje.ne.0) then
  129.         if(iiprou.le.lisobj(/1)) then
  130.         monobj=lisobj(iiprou)
  131.         itch=typobj
  132.         call nomobj(itch,ichc,monobj)
  133.         endif
  134.       else
  135.        CALL NOMENT(ICHC,IIPROU)
  136.       endif
  137.       mbenum=mlobje
  138.       TSTMBC=(MBC.EQ.0.AND.LECTAB.EQ.0)
  139.       GOTO 100
  140.  
  141.   10  CONTINUE
  142. C
  143. C  ON EST EN DEFINITION D'UN NOUVEAU BLOC
  144. C
  145.       SEGINI,MBLOC
  146.       NVQTEM=20
  147.       SEGINI ISSPOT
  148.       ISPOTE= ISSPOT
  149.       NBNOMM=1200
  150.       NINST=1200
  151.       IPVINN=3000
  152.       SEGINI MTXBLC
  153.       NINSTV=0
  154.       MTXBL =MTXBLC
  155.       MBLSUP=MTEMP
  156.       MARGUM=MARM
  157.       MBCONT=MBC
  158.       MBLPRO=0
  159.       MBCOUR=0
  160.       MBFONC=1
  161.       MBERR =0
  162.  
  163. C     Gestion du SOUCI dans le BLOC (ACTUELLEMENT INUTILISE)
  164.       MBSOUC=0
  165.  
  166.       MDEOBJ=MDEOBT
  167.       MFIOBJ=MFIOBT
  168.       MOBJCO=IRETCO
  169. *      write(6,*) 'creation de bloc mblo mde lmnn',mbloc,mdeobj,lmnnom
  170.       CALL NOMOBJ('BLOC    ',CNOM,MBLOC)
  171.       call savseg(mbloc)
  172.       call savseg(ISSPOT)
  173.       call savseg(MTXBLC)
  174.       ICHC(1:1)='&'
  175.       ICHC(2:LONOM)=CNOM(1:LONOM-1)
  176.       NCONBO=ICHC
  177.       ICONBO=1
  178.       IIPROU=ICONBO
  179.       if(mlobje.ne.0) then
  180.         if(iiprou.le.lisobj(/1)) then
  181.         monobj=lisobj(iiprou)
  182.         itch=typobj
  183.         call nomobj(itch,ichc,monobj)
  184.         endif
  185.       else
  186.        CALL NOMENT(ICHC,IIPROU)
  187.       endif
  188.       mbenum=mlobje
  189.       TSTMBC=(MBC.EQ.0 .AND. MDEOBJ.EQ.1 .AND. LECTAB.EQ.0)
  190. *
  191. *     CODE QUI PERMET DE NE PAS EXECUTER LE CONTENU DU BLOC REPETER
  192. *     SI LA VALEUR INITIALE DU COMPTEUR VAUT ZERO (MBC = 0)
  193. *     ATTENTION : CE CODE NE DOIT PAS ETRE EXECUTE SI L'ON EST DANS
  194. *                 UNE PHASE DE LECTURE GIBIANE SANS INTERPRETATION,
  195. *                 COMME PAR EXEMPLE LORS DU PREMIER APPEL D'UNE
  196. *                 PROCEDURE OU LORS DU PASSAGE DANS LA BRANCHE FAUX
  197. *                 D'UN BLOC SI/SINON/FINS (CELA POUR NE PAS PERTURBER
  198. *                 LES VERIFICATIONS SUR L'IMBRICATION DES BLOCS DEBP,
  199. *                 SI ET REPE FAITES DANS LES SUBROUTINES mapr, si ET
  200. *                 sinon)
  201.  100  CONTINUE
  202.  
  203. C     DEBUT Duree passee dans les boucles (Voir FINPRO pour la sortie)
  204.       call timespv(ittime,oothrd)
  205.       IELAPS=ITTIME(1) + ITTIME(2)
  206.       ICPU  =ITTIME(3) + ITTIME(4)
  207.  
  208. C     Initialisation eventuelle des Duree passee dans les boucles
  209.       CNOM =NCONBO(2:LONOM)
  210.       IF(ITPSBO .EQ. 0)THEN
  211.         NBBLOC=1
  212.         NIVMAX=10
  213.         SEGINI,ITPSBL
  214. C       Mise dans le COMMON SMPERF
  215.         ITPSBO=ITPSBL
  216. C       Protection du MENAGE
  217.         CALL SAVSEG(ITPSBL)
  218.         NICOU =1
  219.         ITPSBL.CDPROC(NBBLOC)  = CNOM
  220.         II    =1
  221.  
  222.       ELSE
  223.         ITPSBL = ITPSBO
  224.         SEGACT,ITPSBL*MOD
  225.         NICOU =ITPSBL.NIVCOU
  226.  
  227.         IF(NICOU .GT. 0)THEN
  228. C         Incremente la duree de la boucle qu'on va quitter
  229.           II=ITPSBL.IPRONI(NICOU)
  230.           ITPSBL.DURPRO(1,II)=ITPSBL.DURPRO(1,II) +
  231.      &                       (IELAPS - ITPSBL.TPSPRO(1,II))
  232.           ITPSBL.DURPRO(2,II)=ITPSBL.DURPRO(2,II) +
  233.      &                       (ICPU   - ITPSBL.TPSPRO(2,II))
  234.         ENDIF
  235.  
  236.         NICOU =NICOU + 1
  237.         NBBLOC=ITPSBL.NBAPRO(/1)
  238.         DO II=1,NBBLOC
  239.           IF(CNOM .EQ. ITPSBL.CDPROC(II)) GOTO 11
  240.         ENDDO
  241. C       Ajout de la boucle
  242.         NBBLOC = NBBLOC + 1
  243.         NIVMAX = ITPSBL.IPRONI(/1)
  244.         SEGADJ,ITPSBL
  245.         ITPSBL.CDPROC(NBBLOC)  = CNOM
  246.         II = NBBLOC
  247.  
  248.  11     CONTINUE
  249.         IF(NICOU .GT. NIVMAX)THEN
  250.           NIVMAX=NICOU * 2 + 10
  251.           SEGADJ,ITPSBL
  252.         ENDIF
  253.       ENDIF
  254.  
  255.       ITPSBL.NIVCOU       = NICOU
  256.       ITPSBL.IPRONI(NICOU)= II
  257.       ITPSBL.TPSPRO(1,II) = IELAPS
  258.       ITPSBL.TPSPRO(2,II) = ICPU
  259.       ITPSBL.NBAPRO(II)   = ITPSBL.NBAPRO(II) + 1
  260. C     FIN Duree passee dans les boucles
  261.  
  262.       IF (TSTMBC) THEN
  263.         MBCONT=1
  264.  101    CONTINUE
  265.         CALL NOUTRU
  266.         LECTAB=1
  267.         CALL LIRMO3(MFIN,1,IRET,0,IMOTCO)
  268.         IF (IERR.NE.0) RETURN        
  269.         IF (IRET.EQ.0) GOTO 101
  270.  
  271.         CALL QUETYP(IJCH,0,IRETOU)
  272.         IF(IERR.NE.0) RETURN        
  273.         IF (IRETOU.EQ.0) GOTO 101
  274.  
  275.         IF (IJCH.NE.'BLOC    ') GOTO 101
  276.         CALL LIROBJ('BLOC    ',IRET,1,IRETOU)
  277.         IF(IERR.NE.0) RETURN
  278.         IF (MBLOC.NE.IRET) GOTO 101
  279.  
  280.         LECTAB=0
  281.         CALL REFUS
  282.         CALL FIN
  283.         IF(IERR.NE.0) RETURN
  284.       ENDIF
  285.  
  286.       END
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  

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