Sources Esope | Cast3M

histo1
C HISTO1    SOURCE    BP208322  16/06/02    21:15:03     8937           
 
      SUBROUTINE HISTO1
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
C----------------------------------------------------------------------C
C SUBROUTINE DE L'OPERATEUR "HIST" :                                   C
C APPELEE PAR HISTOG  DANS LE CAS DE LA SYNTAXE 1                      C
C----------------------------------------------------------------------C
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMLENTI
-INC SMLREEL
 
      PARAMETER(MMAX=8,NCLE=2)
      INTEGER KVAL(MMAX),KCLASS(MMAX)
      CHARACTER*4 MCLE(NCLE)
      DATA MCLE/'CLAS','OCCU'/
      LOGICAL ZCLE(NCLE)
 
 
C----------------------- ACQUISITION DES ENTREES -----------------------
 
C     INITIALISATION A 0 DES TABLEAUX
      DO IM=1,MMAX
         KVAL(IM)=0
         KCLASS(IM)=0        
      ENDDO
      DO ICLE=1,NCLE
         ZCLE(ICLE)=.FALSE.
      ENDDO
 
 
C     LECTURE DE M COUPLES DE LISTREEL
      M=0
 101  CONTINUE
      CALL LIROBJ('LISTREEL',MLREE1,0,IRET)
      IF (IERR.NE.0) RETURN
      IF (IRET.EQ.0) GOTO 102
      M=M+1
      CALL LIROBJ('LISTREEL',MLREE2,1,IRET)
      IF (IERR.NE.0) RETURN
c     ON VERIFIE QU'ON NE DEPASSE PAS
      IF(M.GT.MMAX) THEN
        CALL ERREUR(201)
        WRITE(IOIMP,*) MMAX,' couples valeur-classe maximum'
        RETURN
      ENDIF
c     ON ENREGISTRE
      KVAL(M)=MLREE1
      KCLASS(M)=MLREE2
      GOTO 101
 102  CONTINUE
 
c     AUCUN OBJET LU ==> ERREUR
      IF(M.EQ.0) THEN
        MOTERR(1:8)='MODELE  '
        MOTERR(9:16)='LISTREEL'
c       On attend un des objets : %M1:8 %M9:16 %M17:24 %M25:32 %M33:40
        CALL ERREUR(471)
        RETURN
      ENDIF
 
c     MOTS-CLES
      ILU=0
 111  CONTINUE
      ICLE=0
      CALL LIRMOT(MCLE,NCLE,ICLE,0)
      IF (ICLE.EQ.0) GOTO 112
      ILU=ILU+1
      ZCLE(ICLE)=.TRUE.
      GOTO 111
 112  CONTINUE
c     AUCUN MOT CLE LU : ON MET A VRAI LES 2 SORTIES
      IF(ILU.EQ.0) then
        ZCLE(1)=.TRUE.
        ZCLE(2)=.TRUE.
      ENDIF
 
 
C--------------------------- INITIALISATIONS ---------------------------
      N=0
      NPROD=1
 
 
C----------------------- BOUCLE SUR LES GRANDEURS ----------------------
 
      DO 200 IM=1,M
 
c        ON OUVRE LES LISTREELS + QQ VERIF
 
         MLREE1=KVAL(IM)
         MLREE2=KCLASS(IM)
         SEGACT,MLREE1,MLREE2
c          if(iimpi.ge.666) write(ioimp,*) '>>>>>> grandeur',IM,' / ',M
 
c        verif de la dimension des listreels de valeurs
         IF(IM.EQ.1) THEN
           N=MLREE1.PROG(/1)
c          MLENT1= LISTENTI donnant la classe associee a un evenement      
           JG=N
           SEGINI,MLENT1
         ELSEIF(N.NE.MLREE1.PROG(/1)) THEN
           CALL ERREUR(217)
           WRITE(IOIMP,*) 'Les valeurs doivent compter le meme nombre',
     &                    ' d evenements'
           RETURN
         ENDIF
 
c        verif de l'ordre croissant strict des listreels de classe
         NJ=MLREE2.PROG(/1)
         DO J=1,(NJ-1)
           IF(MLREE2.PROG(J).GE.MLREE2.PROG(J+1)) THEN
             CALL ERREUR(249)
             RETURN
           ENDIF
         ENDDO
 
C        --------------- BOUCLE SUR LES EVENEMENTS 
         DO 300 I=1,N
 
            X=MLREE1.PROG(I)
c             if(iimpi.ge.666) write(ioimp,*) '>>> evenement',I,'/',N,X
 
c           SI VALEUR HORS CLASSE,
c           deja reperee => on saute
            IF (IM.GT.1.AND.MLENT1.LECT(I).EQ.0) GOTO 300
c           nouvelle valeur hors classe
            IF(X.LT.MLREE2.PROG(1).OR.X.GT.MLREE2.PROG(NJ)) THEN
              IF(IIMPI.GE.666) WRITE(IOIMP,*) I,'eme evenement de la',
     &                      IM,'eme grandeur hors classe'
c c          -> ERREUR
c c             %m1:8 = %r1 non compris entre %r2 et %r3
c               MOTERR(1:8)='LISTREEL'
c               REAERR(1)=X
c               REAERR(2)=MLREE2.PROG(1)
c               REAERR(3)=MLREE2.PROG(NJ)
c               CALL ERREUR(42)
c               RETURN
c          -> on dit que l'evenement est dans la classe 0
              MLENT1.LECT(I)=0
              GOTO 300
            ENDIF
 
c           RECHERCHE DE LA CLASSE JX
            JX=0
c             write(ioimp,*) 'recherche dans',(MLREE2.PROG(jou),jou=1,NJ)
            DO 320 J=1,(NJ-1)
c   rem : 1 seul test car liste ordonnee et test si hors classe au debut
              IF (X.GE.MLREE2.PROG(J+1)) GOTO 320
              JX=J
              GOTO 310
  320       CONTINUE
  310       CONTINUE
c           on a trouve la classe telle que : 0 &lt; JX &lt; NJ
c             if(iimpi.ge.666) write(ioimp,*) '>>> JX=',JX,' NPROD=',NPROD
            IF (IM.EQ.1) THEN
              MLENT1.LECT(I)=JX
            ELSE
              MLENT1.LECT(I)=MLENT1.LECT(I)+((JX-1)*NPROD)
            ENDIF
 
  300    CONTINUE
C        ----------- FIN DE BOUCLE SUR LES EVENEMENTS 
 
         NPROD=NPROD*(NJ-1)
         SEGDES,MLREE1,MLREE2
 
  200 CONTINUE
C-------------------- FIN DE BOUCLE SUR LES GRANDEURS ------------------
 
 
 
C--------------------- CALCUL DU NOMBRE D'OCCURENCES -------------------
 
c     MLENT2= LISTENTI donnant le nombre d'occurence de chaque classe
      JG=NPROD
      SEGINI,MLENT2
      NJX0=0
 
C     --------------- BOUCLE SUR LES EVENEMENTS 
      DO 600 I=1,N
 
         JX=MLENT1.LECT(I)
         IF(JX.EQ.0) THEN
           NJX0=NJX0+1
           GOTO 600
         ENDIF
         MLENT2.LECT(JX)=MLENT2.LECT(JX)+1         
 
  600 CONTINUE
C     --------------- FIN DE BOUCLE SUR LES EVENEMENTS 
 
      IF(NJX0.NE.0) THEN
        IF (IIMPI.NE.0) 
     &  WRITE(IOIMP,*) NJX0,'evenements detectes hors classe !'
      ENDIF
 
 
C--------------------- ECRITURE DES OBJETS RESULTATS -------------------
 
      IF (ZCLE(2)) THEN
        CALL ECROBJ('LISTENTI',MLENT2)
        SEGDES,MLENT2
      ELSE
        SEGSUP,MLENT2
      ENDIF
 
      IF (ZCLE(1)) THEN
        CALL ECROBJ('LISTENTI',MLENT1)
        SEGDES,MLENT1
      ELSE
        SEGSUP,MLENT1
      ENDIF
 
      RETURN
      END