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

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