Télécharger cvol.eso

Retour à la liste

Numérotation des lignes :

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

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