Télécharger hann.eso

Retour à la liste

Numérotation des lignes :

  1. C HANN SOURCE BP208322 16/11/18 21:17:32 9177
  2. C HANN SOURCE ISPRA 90/02/22
  3. SUBROUTINE HANN
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. CHARACTER *72 TI
  7. CHARACTER*12 MOTX,MOTY
  8. CHARACTER*2 CNH
  9. C=======================================================================
  10. C = CALCUL DE LA 'FENETRE' DE HANNING =
  11. C = =
  12. C = SYNTAXE : =
  13. C = =
  14. C = SPEC = HANN EVO1 N (COUL); =
  15. C = =
  16. C = =
  17. C = EVO1 : OBJET DE TYPE EVOLUTIO CONTENANT LE SPECTRE A TRAITER=
  18. C = ( UNE COURBE SEULEMENT ) =
  19. C = N : NUMERO DE HANNING =
  20. C = COUL : COULEUR ATTRIBUEE A L'OBJET CREE (FACULTATIF) =
  21. C = ( DEFAUT = COULEUR DU EVO1) =
  22. C = =
  23. C = CREATION : 22/02/90 =
  24. C = PROGRAMMEUR : A.P. ET P.P. =
  25. C=======================================================================
  26. C
  27. -INC CCGEOME
  28. -INC CCOPTIO
  29. -INC SMEVOLL
  30. -INC SMLREEL
  31. C
  32. SEGMENT MTRAV1
  33. IMPLIED XX(NPOINT),YY(NPOINT)
  34. ENDSEGMENT
  35. C
  36. C LECTURE DE L'OBJET EVOLUTIO CONTENANT LE SPECTRE
  37. C
  38. CALL LIROBJ('EVOLUTIO',IPSIG,1,IRET2)
  39. IF(IRET2.EQ.0) RETURN
  40. C
  41. C LECTURE DU NUMERO DE HANNING
  42. C
  43. CALL LIRENT(NH,1,IRET1)
  44. IF(IRET1.EQ.0) RETURN
  45. C
  46. C LECTURE DE LA COULEUR
  47. C
  48. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  49. IF(icoul.eq.0) icoul=idcoul+1
  50. icoul=icoul-1
  51. C
  52. IF(IERR.NE.0) RETURN
  53. C
  54. MEVOL1=IPSIG
  55. SEGACT MEVOL1
  56. KEVOL1=MEVOL1.IEVOLL(1)
  57. SEGACT KEVOL1
  58. C
  59. IF(ICOUL.EQ.0) ICOUL=KEVOL1.NUMEVX
  60. MOTX=KEVOL1.NOMEVX
  61. MOTY=KEVOL1.NOMEVY
  62. C
  63. IF(NH.GT.99)THEN
  64. CNH='**'
  65. ELSE
  66. WRITE(CNH,'(I2)')NH
  67. ENDIF
  68. IF(NH.GT.9)THEN
  69. INH=1
  70. ELSE
  71. INH=2
  72. ENDIF
  73. TI='HANNING('//CNH(INH:2)//') '//MEVOL1.IEVTEX(1:59+INH)
  74. C
  75. MLREE1=KEVOL1.IPROGX
  76. MLREE2=KEVOL1.IPROGY
  77. SEGACT MLREE1
  78. SEGACT MLREE2
  79. C
  80. NPOINT=MLREE2.PROG(/1)
  81. C
  82. SEGINI MTRAV1
  83. C
  84. C CHARGEMENT DES TABLEAUX DE TRAVAIL
  85. C
  86. DO 10 I=1,NPOINT
  87. XX(I)=MLREE2.PROG(I)
  88. YY(I)=MLREE1.PROG(I)
  89. 10 CONTINUE
  90. C
  91. C DUPLICATION DES ABSCICES
  92. C
  93. SEGDES MLREE1
  94. JG=NPOINT
  95. SEGINI MLREE1
  96. DO 11 I=1,NPOINT
  97. 11 MLREE1.PROG(I)=YY(I)
  98. SEGDES MLREE1
  99. C
  100. C CALCUL DE LA FENETRE
  101. C
  102. CALL HANNIN(NH,XX,NPOINT,YY)
  103. IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CALCUL DE FENETRE '
  104. C
  105. SEGDES MLREE2
  106. C
  107. C CREATION ET CALCUL DES LISTES DE LA DSP
  108. C
  109. JG=NPOINT
  110. SEGINI MLREE2
  111. DO 20 I=1,NPOINT
  112. MLREE2.PROG(I)=YY(I)
  113. 20 CONTINUE
  114. C
  115. SEGDES MLREE2
  116. C
  117. C CREATION DE L'OBJET EVOLUTIO DSP
  118. C
  119. N=1
  120. SEGINI MEVOLL
  121. IPVO=MEVOLL
  122. IEVTEX=TI
  123. ITYEVO='REEL'
  124. SEGINI KEVOLL
  125. KEVTEX=TI
  126. IEVOLL(1)=KEVOLL
  127. TYPX='LISTREEL'
  128. TYPY='LISTREEL'
  129. C
  130. IPROGX=MLREE1
  131. NOMEVX=MOTX(1:12)
  132. C
  133. IPROGY=MLREE2
  134. NOMEVY=MOTY(1:12)
  135. C
  136. NUMEVX=ICOUL
  137. NUMEVY='REEL'
  138. C
  139. SEGSUP MTRAV1
  140. SEGDES KEVOL1
  141. SEGDES MEVOL1
  142. C
  143. SEGDES KEVOLL,MEVOLL
  144. CALL ECROBJ('EVOLUTIO',IPVO)
  145. C
  146. RETURN
  147. END
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  

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