Télécharger cvol.eso

Retour à la liste

Numérotation des lignes :

  1. C CVOL SOURCE CHAT 05/01/12 22:33:27 5004
  2. *$$$$ CVOL
  3. C CVOL SOURCE ISPRA 90/07/25
  4. SUBROUTINE CVOL
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7. LOGICAL LSYM,LRSYM,LOK
  8. C
  9. C=======================================================================
  10. C = CALCUL DE CONVOLUTION =
  11. C = =
  12. C = SYNTAXE : =
  13. C = =
  14. C = SRLIST = CVOL SLIST RLIST (('NPNE' MM) TYPE) ; =
  15. C = =
  16. C = =
  17. C = SLIST : OBJET DE TYPE LISTREEL CONTENANT LE SIGNAL A TRAITER=
  18. C = RLIST : OBJET DE TYPE LISTREEL CONTENANT LE SIGNAL REPONSE =
  19. C = SRLIST : OBJET DE TYPE LISTREEL CONTENANT LE SIGNAL RESULTAT =
  20. C = =
  21. C = MM : OBJET DE TYPE ENTIER DONNANT LA LONGUEUR DE LA =
  22. C = PARTIE NEGATIVE DU SIGNAL DE REPONSE SI NON SYMETRIE=
  23. C = TYPE : 'SYME' OU 'PADD' (DEFAUT 'SYME') =
  24. C = =
  25. C = =
  26. C = CREATION : 90/08/02 =
  27. C = PROGRAMMEUR : PEG =
  28. C=======================================================================
  29. C
  30. -INC CCOPTIO
  31. -INC SMEVOLL
  32. -INC SMLREEL
  33. -INC CCREEL
  34. C
  35. POINTEUR IPSIG.MLREEL,IPREP.MLREEL
  36. POINTEUR IPRESU.MLREEL
  37. SEGMENT MTRAV
  38. IMPLIED SIG(KNPM),REP(KM),RESU(KN)
  39. ENDSEGMENT
  40. C
  41. PARAMETER (NMOCLE=3)
  42. CHARACTER*4 MOTCLE(NMOCLE)
  43. DATA MOTCLE/'SYME','PADD','NPNE'/
  44. LOK=.TRUE.
  45. C
  46. C DEFAUT (REPONSE SYMETRIQUE,SIGNAL SYMETRIQUE)
  47. C
  48. LRSYM=.TRUE.
  49. LSYM=.TRUE.
  50. C
  51. C LECTURE DE L'OBJET LISTREEL CONTENANT LE SIGNAL
  52. C
  53. CALL LIROBJ('LISTREEL',IPSIG,1,IRET1)
  54. IF(IRET1.EQ.0) RETURN
  55. C
  56. C LECTURE DE L'OBJET LISTREEL CONTENANT LA REPONSE
  57. C
  58. CALL LIROBJ('LISTREEL',IPREP,1,IRET1)
  59. IF(IRET1.EQ.0) RETURN
  60. C
  61. C LECTURE DES OPTIONS
  62. C
  63. 1 CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0)
  64. IF(IVAL.EQ.0)GOTO 9
  65. GOTO(2,3,4),IVAL
  66. C ---> "TYPE"
  67. 2 LSYM=.TRUE.
  68. GOTO 1
  69. 3 LSYM=.FALSE.
  70. GOTO 1
  71. C ---> "NPNE"
  72. 4 LRSYM=.FALSE.
  73. CALL LIRENT(MM,1,IRET1)
  74. IF(IRET1.EQ.0) RETURN
  75. GOTO 1
  76. 9 CONTINUE
  77. C
  78. IF(IERR.NE.0) RETURN
  79. C
  80. C DIMENSION DES TABLEAUX DE TRAVAIL ET TESTS
  81. C
  82. SEGACT IPSIG
  83. KN=IPSIG.PROG(/1)
  84. C
  85. SEGACT IPREP
  86. KKM=IPREP.PROG(/1)
  87. IF (LRSYM)THEN
  88. MM=KKM-1
  89. KM=2*KKM-1
  90. ELSE
  91. KM=KKM
  92. ENDIF
  93. C
  94. IF(KM.EQ.MM)THEN
  95. MP=0
  96. ELSE
  97. MP=KM-MM-1
  98. ENDIF
  99. C
  100. IF(MM.GT.KM)THEN
  101. LOK=.FALSE.
  102. CALL ERREUR(569)
  103. ENDIF
  104. C
  105. IF(LSYM)THEN
  106. IF(MM+1.GT.KN)THEN
  107. LOK=.FALSE.
  108. MOTERR='gauche'
  109. CALL ERREUR(570)
  110. ENDIF
  111. IF(MP+1.GT.KN)THEN
  112. LOK=.FALSE.
  113. MOTERR='droite'
  114. CALL ERREUR(570)
  115. ENDIF
  116. ENDIF
  117. C
  118. IF(.NOT.LOK)THEN
  119. SEGDES IPSIG,IPREP
  120. RETURN
  121. C LSYM=.FALSE.
  122. C WRITE(IOIMP,*)'CVOL:-----> ZERO PADDING'
  123. ENDIF
  124. C
  125. KNPM=KN+MM+MP
  126. C
  127. SEGINI MTRAV
  128. C
  129. C REMPLISSAGE DES TABLEAUX DE TRAVAIL
  130. C
  131. IF(LRSYM)THEN
  132. DO 10 IE1=1,KKM
  133. XXXX =IPREP.PROG(IE1)
  134. REP(MM+IE1) =XXXX
  135. REP(MM+2-IE1)=XXXX
  136. 10 CONTINUE
  137. ELSE
  138. DO 11 IE1=1,KKM
  139. XXXX =IPREP.PROG(IE1)
  140. REP(IE1) =XXXX
  141. 11 CONTINUE
  142. ENDIF
  143. SEGDES IPREP
  144. C
  145. DO 15 IE1=1,KN
  146. SIG(MM+IE1)=IPSIG.PROG(IE1)
  147. 15 CONTINUE
  148. C
  149. SEGDES IPSIG
  150. C
  151. IF(MM.NE.0)THEN
  152. IF (LSYM)THEN
  153. DO 16 IE1=1,MM
  154. SIG(IE1)=SIG(2*MM+2-IE1)
  155. 16 CONTINUE
  156. ELSE
  157. DO 18 IE1=1,MM
  158. SIG(IE1)=0.D0
  159. 18 CONTINUE
  160. ENDIF
  161. ENDIF
  162. IF(MP.NE.0)THEN
  163. IF (LSYM)THEN
  164. DO 17 IE1=1,MP
  165. SIG(MM+KN+IE1)=SIG(MM+KN-IE1)
  166. 17 CONTINUE
  167. ELSE
  168. DO 19 IE1=1,MP
  169. SIG(MM+KN+IE1)=0.D0
  170. 19 CONTINUE
  171. ENDIF
  172. ENDIF
  173. C
  174. CALL CNVOLU(SIG,REP,RESU,KN,KM)
  175. C
  176. C CREATION DE L'OBJET RESULTAT
  177. C
  178. JG=KN
  179. SEGINI IPRESU
  180. C
  181. DO 25 IE1=1,KN
  182. IPRESU.PROG(IE1)=RESU(IE1)
  183. 25 CONTINUE
  184. C
  185. SEGDES IPRESU
  186. SEGSUP MTRAV
  187. C
  188. CALL ECROBJ('LISTREEL',IPRESU)
  189. RETURN
  190. END
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  

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