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    SP204843  26/02/03    21:15:36     12461          
  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.         nob1=lisobj(/1)
  65.         nre1=rliree(/1)
  66.         mbc=max(nob1,nre1)
  67.       endif
  68.       endif
  69.       if(mbc.eq.-1)  CALL LIRENT(MBC,0,IRETOe)
  70.       IF (IERR.NE.0) RETURN
  71. *  TEST QUE L'INSTRUCTION EST EPUISEE - PROBLEME AVEC LA PRECOMPILATION
  72.       if(icle.eq.0) then
  73.       ITCH=' '
  74.       CALL LIROBJ(ITCH,IRET,0,IRETO)
  75.       if(ireto.ne.0)  then
  76.       MOTERR(1:8)=ITCH
  77.       CALL ERREUR(39)
  78.       RETURN
  79.       endif
  80.       endif
  81. *  20 CONTINUE
  82.  
  83.       MDEOBT=MDEOBJ
  84.       MFIOBT=MFIOBJ
  85.       MBLPRT=MBLPRO
  86.       MTXBLC=MTXBL
  87.       MARM = MARGUM
  88.       IF (MBLSUP.NE.0) SEGDES MTXBLC
  89.       ISSPOT=ISPOTE
  90.       SEGDES ISSPOT
  91.       IRETCO=MOBJCO
  92.       SEGDES MBLOC
  93.       MTEMP =MBLOC
  94.       IF (IREBLO.EQ.0) GOTO 10
  95. C
  96. C  LE BLOC REPETER EXISTE DEJA
  97. C
  98.       segini,mbloc=MBLO1
  99.       iouep2(imablu)=mbloc
  100.       SEGACT MBLOC*MOD
  101.       ISSPOT=ISPOTE
  102.       SEGACT ISSPOT*MOD
  103. *      write(6,*) 'ispote ipotem(1) ', ispote, ipotem(1)
  104.       MOBJCO=IRETCO
  105.       mdecip = mdeobt  - mdeobj
  106.       do iou=1,ipotem(/1)
  107.         ipotem(iou)=ipotem(iou)+mdecip
  108.       enddo
  109.       MDEOBJ=MDEOBT
  110.       MFIOBJ=MFIOBT
  111.       MBLPRO=MBLPRT
  112.       MBLSUP=MTEMP
  113.       MARGUM = MARM
  114.       MTXBLC=MTXBL
  115.       SEGACT MTXBLC
  116. *      ILON= MTXBLC(/1)
  117.       MBCOUR=0
  118.       MBCONT=MBC
  119.       MBFONC=0
  120.       MBERR =0
  121.  
  122. C     Gestion du SOUCI dans le BLOC (ACTUELLEMENT INUTILISE)
  123.       MBSOUC=0
  124.  
  125.       ICHC=NCONBO
  126.       ICONBO=1
  127.       IIPROU=ICONBO
  128. *      write(6,*)' bloc2 repete mbloc mdeobj lmnnom',mbloc,mdeobj,lmnnom
  129.  
  130.       if (mlobje.ne.0) then
  131.         nob1=lisobj(/1)
  132.         nre1=rliree(/1)
  133.         nel1=max(nob1,nre1)
  134.         ik = 1
  135.         if (nre1.gt.0) ik = 2
  136.         if (iiprou.le.nel1) then
  137.           if (ik.eq.1) then
  138.             monobj=lisobj(iiprou)
  139.             itch=typobj
  140.             call nomobj(itch,ichc,monobj)
  141.           else
  142.             xval=rliree(iiprou)
  143.             call nomree(ichc,xval)
  144.           endif
  145.         endif
  146.       else
  147.        CALL NOMENT(ICHC,IIPROU)
  148.       endif
  149.       mbenum=mlobje
  150.       TSTMBC=(MBC.EQ.0.AND.LECTAB.EQ.0)
  151.       GOTO 100
  152.  
  153.   10  CONTINUE
  154. C
  155. C  ON EST EN DEFINITION D'UN NOUVEAU BLOC
  156. C
  157.       SEGINI,MBLOC
  158.       NVQTEM=20
  159.       SEGINI ISSPOT
  160.       ISPOTE= ISSPOT
  161.       NBNOMM=1200
  162.       NINST=1200
  163.       IPVINN=3000
  164.       SEGINI MTXBLC
  165.       NINSTV=0
  166.       MTXBL =MTXBLC
  167.       MBLSUP=MTEMP
  168.       MARGUM=MARM
  169.       MBCONT=MBC
  170.       MBLPRO=0
  171.       MBCOUR=0
  172.       MBFONC=1
  173.       MBERR =0
  174.  
  175. C     Gestion du SOUCI dans le BLOC (ACTUELLEMENT INUTILISE)
  176.       MBSOUC=0
  177.  
  178.       MDEOBJ=MDEOBT
  179.       MFIOBJ=MFIOBT
  180.       MOBJCO=IRETCO
  181. *      write(6,*) 'creation de bloc mblo mde lmnn',mbloc,mdeobj,lmnnom
  182.       CALL NOMOBJ('BLOC    ',CNOM,MBLOC)
  183.       call savseg(mbloc)
  184.       call savseg(ISSPOT)
  185.       call savseg(MTXBLC)
  186.       ICHC(1:1)='&'
  187.       ICHC(2:LONOM)=CNOM(1:LONOM-1)
  188.       NCONBO=ICHC
  189.       ICONBO=1
  190.       IIPROU=ICONBO
  191.       if (mlobje.ne.0) then
  192.         nob1=lisobj(/1)
  193.         nre1=rliree(/1)
  194.         nel1=max(nob1,nre1)
  195.         ik = 1
  196.         if (nre1.gt.0) ik = 2
  197.         if (iiprou.le.nel1) then
  198.           if (ik.eq.1) then
  199.             monobj=lisobj(iiprou)
  200.             itch=typobj
  201.             call nomobj(itch,ichc,monobj)
  202.           else
  203.             xval=rliree(iiprou)
  204.             call nomree(ichc,xval)
  205.           endif
  206.         endif
  207.       else
  208.        CALL NOMENT(ICHC,IIPROU)
  209.       endif
  210.       mbenum=mlobje
  211.       TSTMBC=(MBC.EQ.0 .AND. MDEOBJ.EQ.1 .AND. LECTAB.EQ.0)
  212. *
  213. *     CODE QUI PERMET DE NE PAS EXECUTER LE CONTENU DU BLOC REPETER
  214. *     SI LA VALEUR INITIALE DU COMPTEUR VAUT ZERO (MBC = 0)
  215. *     ATTENTION : CE CODE NE DOIT PAS ETRE EXECUTE SI L'ON EST DANS
  216. *                 UNE PHASE DE LECTURE GIBIANE SANS INTERPRETATION,
  217. *                 COMME PAR EXEMPLE LORS DU PREMIER APPEL D'UNE
  218. *                 PROCEDURE OU LORS DU PASSAGE DANS LA BRANCHE FAUX
  219. *                 D'UN BLOC SI/SINON/FINS (CELA POUR NE PAS PERTURBER
  220. *                 LES VERIFICATIONS SUR L'IMBRICATION DES BLOCS DEBP,
  221. *                 SI ET REPE FAITES DANS LES SUBROUTINES mapr, si ET
  222. *                 sinon)
  223.  100  CONTINUE
  224.  
  225. C     DEBUT Duree passee dans les boucles (Voir FINPRO pour la sortie)
  226.       call timespv(ittime,oothrd)
  227.       IELAPS=ITTIME(1) + ITTIME(2)
  228.       ICPU  =ITTIME(3) + ITTIME(4)
  229.  
  230. C     Initialisation eventuelle des Duree passee dans les boucles
  231.       CNOM =NCONBO(2:LONOM)
  232.       IF(ITPSBO .EQ. 0)THEN
  233.         NBBLOC=1
  234.         NIVMAX=10
  235.         SEGINI,ITPSBL
  236. C       Mise dans le COMMON SMPERF
  237.         ITPSBO=ITPSBL
  238. C       Protection du MENAGE
  239.         CALL SAVSEG(ITPSBL)
  240.         NICOU =1
  241.         ITPSBL.CDPROC(NBBLOC)  = CNOM
  242.         II    =1
  243.  
  244.       ELSE
  245.         ITPSBL = ITPSBO
  246.         SEGACT,ITPSBL*MOD
  247.         NICOU =ITPSBL.NIVCOU
  248.  
  249.         IF(NICOU .GT. 0)THEN
  250. C         Incremente la duree de la boucle qu'on va quitter
  251.           II=ITPSBL.IPRONI(NICOU)
  252.           ITPSBL.DURPRO(1,II)=ITPSBL.DURPRO(1,II) +
  253.      &                       (IELAPS - ITPSBL.TPSPRO(1,II))
  254.           ITPSBL.DURPRO(2,II)=ITPSBL.DURPRO(2,II) +
  255.      &                       (ICPU   - ITPSBL.TPSPRO(2,II))
  256.         ENDIF
  257.  
  258.         NICOU =NICOU + 1
  259.         NBBLOC=ITPSBL.NBAPRO(/1)
  260.         DO II=1,NBBLOC
  261.           IF(CNOM .EQ. ITPSBL.CDPROC(II)) GOTO 11
  262.         ENDDO
  263. C       Ajout de la boucle
  264.         NBBLOC = NBBLOC + 1
  265.         NIVMAX = ITPSBL.IPRONI(/1)
  266.         SEGADJ,ITPSBL
  267.         ITPSBL.CDPROC(NBBLOC)  = CNOM
  268.         II = NBBLOC
  269.  
  270.  11     CONTINUE
  271.         IF(NICOU .GT. NIVMAX)THEN
  272.           NIVMAX=NICOU * 2 + 10
  273.           SEGADJ,ITPSBL
  274.         ENDIF
  275.       ENDIF
  276.  
  277.       ITPSBL.NIVCOU       = NICOU
  278.       ITPSBL.IPRONI(NICOU)= II
  279.       ITPSBL.TPSPRO(1,II) = IELAPS
  280.       ITPSBL.TPSPRO(2,II) = ICPU
  281.       ITPSBL.NBAPRO(II)   = ITPSBL.NBAPRO(II) + 1
  282. C     FIN Duree passee dans les boucles
  283.  
  284.       IF (TSTMBC) THEN
  285.         MBCONT=1
  286.  101    CONTINUE
  287.         CALL NOUTRU
  288.         LECTAB=1
  289.         CALL LIRMO3(MFIN,1,IRET,0,IMOTCO)
  290.         IF (IERR.NE.0) RETURN        
  291.         IF (IRET.EQ.0) GOTO 101
  292.  
  293.         CALL QUETYP(IJCH,0,IRETOU)
  294.         IF(IERR.NE.0) RETURN        
  295.         IF (IRETOU.EQ.0) GOTO 101
  296.  
  297.         IF (IJCH.NE.'BLOC    ') GOTO 101
  298.         CALL LIROBJ('BLOC    ',IRET,1,IRETOU)
  299.         IF(IERR.NE.0) RETURN
  300.         IF (MBLOC.NE.IRET) GOTO 101
  301.  
  302.         LECTAB=0
  303.         CALL REFUS
  304.         CALL FIN
  305.         IF(IERR.NE.0) RETURN
  306.       ENDIF
  307.  
  308.       END
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  

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