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