Télécharger brui.eso

Retour à la liste

Numérotation des lignes :

  1. C BRUI SOURCE CB215821 19/07/31 21:15:34 10277
  2. SUBROUTINE BRUI
  3. C-----------------------------------------------------------------------
  4. C Génération d'un bruit blanc obéissant à une loi statistique décrite
  5. C via les arguments transmis. Ce bruit est utilisée pour créer :
  6. C 1) Un LISTREEL lorsque on donne le nombre de valeurs à générer ;
  7. C 2) Un objet EVOLUTION si un LISTREEL de temps est fourni ;
  8. C 3) Un CHAMPOINT si le maillage GEO1 est précisé ;
  9. C 4) Un LISTENTI lorsqu'on tire des variables entiere selon un
  10. C processus de Poisson.
  11. C-----------------------------------------------------------------------
  12. C
  13. C---------------------------
  14. C Phrase d'appel (GIBIANE) :
  15. C---------------------------
  16. C
  17. C | ENTI2 |
  18. C RES1 = 'BRUI' 'BLAN' MOT1 FLOT1 (FLOT2) | LREEL1 (COUL) | (ENTI3) ;
  19. C | GEO1 |
  20. C ou
  21. C
  22. C RES1 = 'BRUI' 'BLAN' 'POIS' ENTI1 ENTI2 (ENTI3)
  23. C
  24. C------------------------
  25. C Opérandes et résultat :
  26. C------------------------
  27. C
  28. C 1e Syntaxe :
  29. C ------------
  30. C
  31. C BLAN : Mot indiquant qu'il s'agit d'un bruit blanc
  32. C MOT1 : Mot indiquant la loi statistique suivi par le bruit :
  33. C MOT1 = 'GAUS' : Distribution gaussienne,
  34. C MOT1 = 'UNIF' : Distribution uniforme,
  35. C MOT1 = 'EXPO' : Distribution exponentielle.
  36. C FLOT1 : Moyenne statistique du bruit à créer. Ne sert à rien
  37. C si MOT1='EXPO'.
  38. C FLOT2 : Ecart type du bruit à créer. Ne sert à rien si MOT1='POIS'.
  39. C ENTI2 : Nombre de valeurs du LISTREEL à générer.
  40. C LREEL1 : LISTREEL contenant la liste des temps pour l'EVOLUTION.
  41. C COUL : Mot clef indiquant la couleur associée à l'EVOLUTION RES1.
  42. C GEO1 : Maillage contenant le support géométrique du CHAMPOINT.
  43. C ENTI3 : Entier positif ou nul. Modifie l'initialisation du bruit.
  44. C
  45. C RES1 : LISTREEL, EVOLUTION, CHAMPOINT selon la syntaxe utilisée.
  46. C
  47. C 2e Syntaxe :
  48. C ------------
  49. C
  50. C BLAN : Mot indiquant qu'il s'agit d'un bruit blanc
  51. C 'POIS' : Mot-cle que les valeurs suivent une distribution de Poisson.
  52. C ENTI1 : Valeur moyenne de la distribution.
  53. C ENTI2 : Nombre de valeurs du LISTENTI à générer.
  54. C ENTI3 : Entier positif ou nul. Modifie l'initialisation du bruit.
  55. C
  56. C RES1 : Resultat, LISTENTI de valeurs aleatoires.
  57. C
  58. C----------------------
  59. C Variables en COMMON :
  60. C----------------------
  61. C
  62. C NBCOUL : Nombre de couleurs admises par CASTEM (in CCGEOME)
  63. C NCOUL : Tableau de CHAR*4, dim NBCOUL, Noms des couleurs (in CCGEOME)
  64. C IDCOUL : Valeur de la couleurs par défaut (in CCOPTIO)
  65. C IERR : Numéro de l'erreur détectée (in CCOPTIO)
  66. C IFOUR : Indique le type de calcul (in CCOPTIO)
  67. C NIFOUR : Numéro de l'harmonique de fourier si IFOUR=1 (cf CCOPTIO)
  68. C TITREE : CHAR*72, titre des tracés (cf CCOPTIO)
  69. C
  70. C-----------------------------------------------------------------------
  71. C
  72. C Langage : ESOPE + FORTRAN77
  73. C
  74. C Modifs : F.DABBENE 06/95 (Extension LISTREEL et CHAMPOINT)
  75. C Modifs : S.PASCAL 06/06 (Extension distribution de Poisson)
  76. C
  77. C-----------------------------------------------------------------------
  78. C
  79. IMPLICIT INTEGER(I-N)
  80. IMPLICIT REAL*8(A-H,O-Z)
  81. C
  82. -INC CCGEOME
  83. -INC CCOPTIO
  84. -INC SMEVOLL
  85. -INC SMLENTI
  86. -INC SMLREEL
  87. -INC SMCHPOI
  88. -INC SMELEME
  89. C
  90. CHARACTER*4 MOTYP(4),MOTB(1)
  91. C
  92. DATA MOTB /'BLAN'/
  93. DATA MOTYP /'GAUS','UNIF','EXPO','POIS'/
  94. C
  95. C- Lecture du type de bruit
  96. C
  97. CALL LIRMOT(MOTB,1,IVAL,1)
  98. IF (IVAL.EQ.0) RETURN
  99. C
  100. C- Lecture du type de distribution
  101. C
  102. CALL LIRMOT(MOTYP,4,IVAB,1)
  103. IF (IVAB.EQ.0) RETURN
  104. C
  105. C- Lecture de la moyenne et de l'écart type
  106. C
  107. IF (IVAB.EQ.4) THEN
  108. CALL LIRENT(NMOYE,1,IRET1)
  109. IF (IERR.NE.0) RETURN
  110. ELSE
  111. CALL LIRREE(VMOYE,1,IRET1)
  112. IF (IERR.NE.0) RETURN
  113. CALL LIRREE(ECAR,1,IRET1)
  114. IF (IERR.NE.0) RETURN
  115. IF (IVAB.EQ.3) THEN
  116. REAERR(1) = REAL(VMOYE)
  117. CALL ERREUR(-304)
  118. VMOYE = 0.D0
  119. ENDIF
  120. IF (ECAR.LE.0.D0) THEN
  121. REAERR(1) = REAL(0.D0)
  122. REAERR(2) = REAL(ECAR)
  123. CALL ERREUR(191)
  124. RETURN
  125. ENDIF
  126. ENDIF
  127. C
  128. C- Lecture d'un LISTREEL, d'un MELEME ou d'un ENTIER
  129. C
  130. CALL LIROBJ('LISTREEL',IPT1,0,IRET1)
  131. IF (IERR.NE.0) RETURN
  132. IK1 = 0
  133. IF (IRET1.EQ.0) THEN
  134. CALL LIROBJ('MAILLAGE',IPT1,0,IRET1)
  135. IF (IERR.NE.0) RETURN
  136. IK1 = 1
  137. ENDIF
  138. IF (IRET1.EQ.0) THEN
  139. CALL LIRENT(IPT1,1,IRET1)
  140. IF (IERR.NE.0) RETURN
  141. IK1 = 2
  142. ENDIF
  143. C
  144. C- Lecture facultative pour l'initialisation du générateur
  145. C
  146. CALL LIRENT(NSTRT,0,IRET1)
  147. IF (IRET1.EQ.0) THEN
  148. NSTRT = 0
  149. ELSEIF (NSTRT.LT.0) THEN
  150. INTERR(1) = 0
  151. INTERR(2) = NSTRT
  152. CALL ERREUR(190)
  153. RETURN
  154. ENDIF
  155. C
  156. C- Lecture facultative de la couleur si RES1 est une évolution
  157. C
  158. IF (IK1.EQ.0) THEN
  159. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  160. IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  161. ICOUL=ICOUL-1
  162. ENDIF
  163. C
  164. C------------------------------------------
  165. C Génération du LISTREEL de NPTBLO valeurs
  166. C------------------------------------------
  167. C
  168. C- Initialisation de NPTBLO, nombre de valeurs à générer.
  169. C- Les éléments du MELEME sont transformés en POI1 si nécessaire.
  170. C- Le maillage de pointeur IPT1 est ACTIF en sortie de CHANGE.
  171. C
  172. IF (IK1.EQ.0) THEN
  173. MLREEL = IPT1
  174. SEGACT MLREEL
  175. NPTBLO = PROG(/1)
  176. SEGDES MLREEL
  177. ELSEIF (IK1.EQ.1) THEN
  178. MELEME = IPT1
  179. SEGACT MELEME
  180. NBSOUS = LISOUS(/1)
  181. IF ((NBSOUS.NE.0).OR.(ITYPEL.NE.1)) THEN
  182. CALL CHANGE(IPT1,1)
  183. IF (IERR.NE.0) RETURN
  184. MELEME = IPT1
  185. ENDIF
  186. NPTBLO = NUM(/2)
  187. SEGDES MELEME
  188. ELSE
  189. NPTBLO = IPT1
  190. ENDIF
  191. C
  192. C- Création du LISTREEL ou du LISTENTI qui va contenir les valeurs
  193. C- créées.
  194. C
  195. JG = NPTBLO
  196. IF (JG .GE. 0) THEN
  197. IF (IVAB.EQ.4) THEN
  198. SEGINI MLENTI
  199. ELSE
  200. SEGINI MLREEL
  201. ENDIF
  202. ELSE
  203. C Cas ou la taille donnee est negative
  204. INTERR = NPTBLO
  205. CALL ERREUR(36)
  206. RETURN
  207. ENDIF
  208. C
  209. C- Initialisation du générateur TDRAND
  210. C
  211. DO 10 I=1,NSTRT
  212. CALL TDRAND(XRAN)
  213. 10 CONTINUE
  214. C
  215. C- Génération du bruit selon le type de loi repéré par IVAB
  216. C- 1 - Distribution Gaussienne
  217. C- 2 - Distribution Uniforme
  218. C- 3 - Distribution Exponentielle
  219. C- 4 - Distribution de Poisson
  220. C
  221. IF (IVAB.EQ.1) THEN
  222. DO 20 I=1,NPTBLO
  223. AK = ECAR
  224. CALL TDRAND(XRAN)
  225. IF (XRAN.GT.0.5D0) THEN
  226. AK = -ECAR
  227. XRAN = 1.D0 - XRAN
  228. ENDIF
  229. IF (XRAN.LT.1.D-6) XRAN=1.D-6
  230. T = SQRT( LOG(1.D0 / (XRAN*XRAN)) )
  231. YY = VMOYE + AK * ( T - (2.30753D0 + 0.27061D0*T) /
  232. # (1.0D0 + T * (0.99229D0 + 0.04481D0*T)))
  233. PROG(I) = YY
  234. 20 CONTINUE
  235. ELSEIF (IVAB.EQ.2) THEN
  236. DO 30 I=1,NPTBLO
  237. CALL TDRAND(XRAN)
  238. YY =VMOYE + (XRAN - 0.5D0) * 2.D0 * ECAR
  239. PROG(I)=YY
  240. 30 CONTINUE
  241. ELSEIF (IVAB.EQ.3) THEN
  242. DO 40 I=1,NPTBLO
  243. CALL TDRAND(XRAN)
  244. IF (XRAN.LT.1.D-6) XRAN = 1.D-6
  245. YY = -LOG(XRAN) * ECAR
  246. PROG(I)= YY
  247. 40 CONTINUE
  248. ELSE
  249. C Pour generer des variables selon une distrib. de Poisson, on emploi 2
  250. C methodes differentes selon que la moyenne de la distrib. est sup. ou
  251. C non a la valeur 50 :
  252. C - Si sup. a 50 : approximation par une gaussienne ;
  253. C - Sinon : methode directe.
  254. XMOYE=FLOAT(NMOYE)
  255. IF (NMOYE.GE.50) THEN
  256. DO 50 I=1,NPTBLO
  257. AK = SQRT(XMOYE)
  258. CALL TDRAND(XRAN)
  259. IF (XRAN.GT.0.5D0) THEN
  260. AK = -1.D0*AK
  261. XRAN = 1.D0 - XRAN
  262. ENDIF
  263. IF (XRAN.LT.1.D-6) XRAN=1.D-6
  264. T = SQRT( LOG(1.D0 / (XRAN*XRAN)) )
  265. YY = XMOYE + AK * ( T - (2.30753D0 + 0.27061D0*T) /
  266. # (1.0D0 + T * (0.99229D0 + 0.04481D0*T)))
  267. LECT(I) = INT(YY)
  268. 50 CONTINUE
  269. ELSE
  270. XMOYE = EXP(-1.D0*XMOYE)
  271. DO 60 I=1,NPTBLO
  272. CALL TDRAND(XRAN)
  273. A=XRAN
  274. DO 61 J=1,(10*NPTBLO)
  275. CALL TDRAND(XRAN)
  276. A=A*XRAN
  277. IF (A.LT.XMOYE) THEN
  278. LECT(I) = J
  279. GOTO 60
  280. ENDIF
  281. 61 CONTINUE
  282. 60 CONTINUE
  283. ENDIF
  284. ENDIF
  285. C
  286. IF (IVAB.EQ.4) THEN
  287. SEGDES MLENTI
  288. ELSE
  289. SEGDES MLREEL
  290. ENDIF
  291. C
  292. C- Création des objets EVOLUTION, CHAMPOINT, LISTREEL ou LISTENTI
  293. C
  294. IF (IK1.EQ.0) THEN
  295. N = 1
  296. SEGINI MEVOLL
  297. IEVTEX = TITREE
  298. ITYEVO = 'REEL'
  299. SEGINI KEVOLL
  300. KEVTEX = TITREE
  301. IEVOLL(1) = KEVOLL
  302. NUMEVX = ICOUL
  303. NUMEVY = 'REEL'
  304. TYPX = 'LISTREEL'
  305. TYPY = 'LISTREEL'
  306. IPROGX = IPT1
  307. NOMEVX = 'TEMPS'
  308. IPROGY = MLREEL
  309. NOMEVY = 'SIGNAL'
  310. SEGDES KEVOLL,MEVOLL
  311. CALL ECROBJ('EVOLUTIO',MEVOLL)
  312. ELSEIF (IK1.EQ.1) THEN
  313. NAT = 1
  314. NSOUPO = 1
  315. SEGINI MCHPOI
  316. MTYPOI = ' '
  317. MOCHDE = ' '
  318. JATTRI(1) = 2
  319. IFOPOI = IFOUR
  320. NC = 1
  321. SEGINI MSOUPO
  322. IPCHP(1) = MSOUPO
  323. NOCOMP(1) = 'SCAL'
  324. IGEOC = MELEME
  325. NOHARM(1) = NIFOUR
  326. N = NPTBLO
  327. SEGINI MPOVAL
  328. IPOVAL = MPOVAL
  329. SEGACT MLREEL
  330. DO 70 I=1,NPTBLO
  331. VPOCHA(I,1) = PROG(I)
  332. 70 CONTINUE
  333. SEGSUP MLREEL
  334. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  335. CALL ECROBJ('CHPOINT ',MCHPOI)
  336. ELSE
  337. IF (IVAB.EQ.4) THEN
  338. CALL ECROBJ('LISTENTI',MLENTI)
  339. ELSE
  340. CALL ECROBJ('LISTREEL',MLREEL)
  341. ENDIF
  342. ENDIF
  343. C
  344. END
  345.  
  346.  
  347.  

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