Télécharger histo1.eso

Retour à la liste

Numérotation des lignes :

  1. C HISTO1 SOURCE BP208322 16/06/02 21:15:03 8937
  2.  
  3. SUBROUTINE HISTO1
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6.  
  7. C----------------------------------------------------------------------C
  8. C SUBROUTINE DE L'OPERATEUR "HIST" : C
  9. C APPELEE PAR HISTOG DANS LE CAS DE LA SYNTAXE 1 C
  10. C----------------------------------------------------------------------C
  11.  
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMLENTI
  16. -INC SMLREEL
  17.  
  18. PARAMETER(MMAX=8,NCLE=2)
  19. INTEGER KVAL(MMAX),KCLASS(MMAX)
  20. CHARACTER*4 MCLE(NCLE)
  21. DATA MCLE/'CLAS','OCCU'/
  22. LOGICAL ZCLE(NCLE)
  23.  
  24.  
  25. C----------------------- ACQUISITION DES ENTREES -----------------------
  26.  
  27. C INITIALISATION A 0 DES TABLEAUX
  28. DO IM=1,MMAX
  29. KVAL(IM)=0
  30. KCLASS(IM)=0
  31. ENDDO
  32. DO ICLE=1,NCLE
  33. ZCLE(ICLE)=.FALSE.
  34. ENDDO
  35.  
  36.  
  37. C LECTURE DE M COUPLES DE LISTREEL
  38. M=0
  39. 101 CONTINUE
  40. CALL LIROBJ('LISTREEL',MLREE1,0,IRET)
  41. IF (IERR.NE.0) RETURN
  42. IF (IRET.EQ.0) GOTO 102
  43. M=M+1
  44. CALL LIROBJ('LISTREEL',MLREE2,1,IRET)
  45. IF (IERR.NE.0) RETURN
  46. c ON VERIFIE QU'ON NE DEPASSE PAS
  47. IF(M.GT.MMAX) THEN
  48. CALL ERREUR(201)
  49. WRITE(IOIMP,*) MMAX,' couples valeur-classe maximum'
  50. RETURN
  51. ENDIF
  52. c ON ENREGISTRE
  53. KVAL(M)=MLREE1
  54. KCLASS(M)=MLREE2
  55. GOTO 101
  56. 102 CONTINUE
  57.  
  58. c AUCUN OBJET LU ==> ERREUR
  59. IF(M.EQ.0) THEN
  60. MOTERR(1:8)='MODELE '
  61. MOTERR(9:16)='LISTREEL'
  62. c On attend un des objets : %M1:8 %M9:16 %M17:24 %M25:32 %M33:40
  63. CALL ERREUR(471)
  64. RETURN
  65. ENDIF
  66.  
  67. c MOTS-CLES
  68. ILU=0
  69. 111 CONTINUE
  70. ICLE=0
  71. CALL LIRMOT(MCLE,NCLE,ICLE,0)
  72. IF (ICLE.EQ.0) GOTO 112
  73. ILU=ILU+1
  74. ZCLE(ICLE)=.TRUE.
  75. GOTO 111
  76. 112 CONTINUE
  77. c AUCUN MOT CLE LU : ON MET A VRAI LES 2 SORTIES
  78. IF(ILU.EQ.0) then
  79. ZCLE(1)=.TRUE.
  80. ZCLE(2)=.TRUE.
  81. ENDIF
  82.  
  83.  
  84. C--------------------------- INITIALISATIONS ---------------------------
  85. N=0
  86. NPROD=1
  87.  
  88.  
  89. C----------------------- BOUCLE SUR LES GRANDEURS ----------------------
  90.  
  91. DO 200 IM=1,M
  92.  
  93. c ON OUVRE LES LISTREELS + QQ VERIF
  94.  
  95. MLREE1=KVAL(IM)
  96. MLREE2=KCLASS(IM)
  97. SEGACT,MLREE1,MLREE2
  98. c if(iimpi.ge.666) write(ioimp,*) '>>>>>> grandeur',IM,' / ',M
  99.  
  100. c verif de la dimension des listreels de valeurs
  101. IF(IM.EQ.1) THEN
  102. N=MLREE1.PROG(/1)
  103. c MLENT1= LISTENTI donnant la classe associee a un evenement
  104. JG=N
  105. SEGINI,MLENT1
  106. ELSEIF(N.NE.MLREE1.PROG(/1)) THEN
  107. CALL ERREUR(217)
  108. WRITE(IOIMP,*) 'Les valeurs doivent compter le meme nombre',
  109. & ' d evenements'
  110. RETURN
  111. ENDIF
  112.  
  113. c verif de l'ordre croissant strict des listreels de classe
  114. NJ=MLREE2.PROG(/1)
  115. DO J=1,(NJ-1)
  116. IF(MLREE2.PROG(J).GE.MLREE2.PROG(J+1)) THEN
  117. CALL ERREUR(249)
  118. RETURN
  119. ENDIF
  120. ENDDO
  121.  
  122. C --------------- BOUCLE SUR LES EVENEMENTS
  123. DO 300 I=1,N
  124.  
  125. X=MLREE1.PROG(I)
  126. c if(iimpi.ge.666) write(ioimp,*) '>>> evenement',I,'/',N,X
  127.  
  128. c SI VALEUR HORS CLASSE,
  129. c deja reperee => on saute
  130. IF (IM.GT.1.AND.MLENT1.LECT(I).EQ.0) GOTO 300
  131. c nouvelle valeur hors classe
  132. IF(X.LT.MLREE2.PROG(1).OR.X.GT.MLREE2.PROG(NJ)) THEN
  133. IF(IIMPI.GE.666) WRITE(IOIMP,*) I,'eme evenement de la',
  134. & IM,'eme grandeur hors classe'
  135. c c -> ERREUR
  136. c c %m1:8 = %r1 non compris entre %r2 et %r3
  137. c MOTERR(1:8)='LISTREEL'
  138. c REAERR(1)=X
  139. c REAERR(2)=MLREE2.PROG(1)
  140. c REAERR(3)=MLREE2.PROG(NJ)
  141. c CALL ERREUR(42)
  142. c RETURN
  143. c -> on dit que l'evenement est dans la classe 0
  144. MLENT1.LECT(I)=0
  145. GOTO 300
  146. ENDIF
  147.  
  148. c RECHERCHE DE LA CLASSE JX
  149. JX=0
  150. c write(ioimp,*) 'recherche dans',(MLREE2.PROG(jou),jou=1,NJ)
  151. DO 320 J=1,(NJ-1)
  152. c rem : 1 seul test car liste ordonnee et test si hors classe au debut
  153. IF (X.GE.MLREE2.PROG(J+1)) GOTO 320
  154. JX=J
  155. GOTO 310
  156. 320 CONTINUE
  157. 310 CONTINUE
  158. c on a trouve la classe telle que : 0 < JX < NJ
  159. c if(iimpi.ge.666) write(ioimp,*) '>>> JX=',JX,' NPROD=',NPROD
  160. IF (IM.EQ.1) THEN
  161. MLENT1.LECT(I)=JX
  162. ELSE
  163. MLENT1.LECT(I)=MLENT1.LECT(I)+((JX-1)*NPROD)
  164. ENDIF
  165.  
  166. 300 CONTINUE
  167. C ----------- FIN DE BOUCLE SUR LES EVENEMENTS
  168.  
  169. NPROD=NPROD*(NJ-1)
  170. SEGDES,MLREE1,MLREE2
  171.  
  172. 200 CONTINUE
  173. C-------------------- FIN DE BOUCLE SUR LES GRANDEURS ------------------
  174.  
  175.  
  176.  
  177. C--------------------- CALCUL DU NOMBRE D'OCCURENCES -------------------
  178.  
  179. c MLENT2= LISTENTI donnant le nombre d'occurence de chaque classe
  180. JG=NPROD
  181. SEGINI,MLENT2
  182. NJX0=0
  183.  
  184. C --------------- BOUCLE SUR LES EVENEMENTS
  185. DO 600 I=1,N
  186.  
  187. JX=MLENT1.LECT(I)
  188. IF(JX.EQ.0) THEN
  189. NJX0=NJX0+1
  190. GOTO 600
  191. ENDIF
  192. MLENT2.LECT(JX)=MLENT2.LECT(JX)+1
  193.  
  194. 600 CONTINUE
  195. C --------------- FIN DE BOUCLE SUR LES EVENEMENTS
  196.  
  197. IF(NJX0.NE.0) THEN
  198. IF (IIMPI.NE.0)
  199. & WRITE(IOIMP,*) NJX0,'evenements detectes hors classe !'
  200. ENDIF
  201.  
  202.  
  203. C--------------------- ECRITURE DES OBJETS RESULTATS -------------------
  204.  
  205. IF (ZCLE(2)) THEN
  206. CALL ECROBJ('LISTENTI',MLENT2)
  207. SEGDES,MLENT2
  208. ELSE
  209. SEGSUP,MLENT2
  210. ENDIF
  211.  
  212. IF (ZCLE(1)) THEN
  213. CALL ECROBJ('LISTENTI',MLENT1)
  214. SEGDES,MLENT1
  215. ELSE
  216. SEGSUP,MLENT1
  217. ENDIF
  218.  
  219. RETURN
  220. END
  221.  
  222.  
  223.  
  224.  

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