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

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