1 : C FILTRE SOURCE CHAT 07/10/29 21:19:48 5940 2 : SUBROUTINE FILTRE 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C 6 : C======================================================================= 7 : C = CALCUL DE FILTRES PASSE-HAUT, PASSE-BAS,EN I*OMEGA 8 : C = 9 : C = SYNTAXE : 10 : C = 11 : C = FILTRE = FILT NN TYPE 'PHAU' FC (SORT 'REIM') DFRQ DF 12 : C = 'PBAS' FC 'MOPH' 13 : C = 'OMEG' NP 14 : C = 15 : C = NN EXPOSANT TEL QUE NPOINT=2**NN 16 : C = 17 : C = TYPE MOT-CLE 18 : C = 19 : C = SUIVI DU MOT HAUT : POUR UN FILTRE PASSE-HAUT 20 : C = BAS : POUR UN FILTRE PASSE-BAS 21 : C = OMEG : POUR UN FILTRE EN OMEGA 22 : C = 23 : C = FC FREQUENCE DE COUPURE DU FILTRE 24 : C = 25 : C = NP PUISSANCE DU FILTRE 26 : C = 27 : C = SORT MOT-CLE FACULTATIF : PAR DEFAUT MOPH 28 : C = 29 : C = SUIVI DU MOT REIM : PARTIES REELLES ET IMAGINAIRES 30 : C = MOPH : MODULE ET PHASE 31 : C = 32 : C = 33 : C = DFRQ MOT-CLE 34 : C = 35 : C = SUIVI DE LA VALEUR DU PAS EN FREQUENCE EN HZ 36 : C = 37 : C = CREATION : 16/04/88 38 : C = F.ROULLIER 39 : C======================================================================= 40 : C 41 : CHARACTER*4 ISORT(2),MOCLE(3),ITYPE(3) 42 : CHARACTER*4 IBLAN 43 : SEGMENT TEMPP 44 : IMPLIED AA(NP),BB(NP),XX(NP),OMEG(NP) 45 : ENDSEGMENT 46 : C 47 : -INC CCGEOME 48 : -INC CCOPTIO 49 : -INC CCREEL 50 : -INC SMEVOLL 51 : -INC SMLREEL 52 : C 53 : DATA IBLAN 54 : 1/' '/ 55 : DATA ISORT/'REIM','MOPH'/ 56 : DATA ITYPE/'PHAU','PBAS','OMEG'/ 57 : DATA MOCLE/'TYPE','SORT','DFRQ'/ 58 : ISOR=2 59 : DEGRES=180.D0/XPI 60 : XPI2=XPI*2.D0 61 : ITYP=0 62 : C 63 : C LECTURE DE L'EXPOSANT NN 64 : C 64 : CALL LIRENT(NN,1,IRETOU) 65 : IF(IRETOU.EQ.0) GOTO 666 66 : C 66 : 10 CALL LIRMOT(MOCLE,3,IRETOU,0) 67 : C 68 : IF (IRETOU.EQ.0) GO TO 30 69 : GO TO (11,12,13) IRETOU 70 : GO TO 30 71 : C 72 : 11 CONTINUE 73 : C LECTURE DU TYPE DE FILTRE 73 : CALL LIRMOT(ITYPE,3,ITYP,1) 74 : C 75 : GO TO (21,21,23) ITYP 76 : C 77 : 21 CONTINUE 78 : C LECTURE DE LA FREQUENCE DE COUPURE 78 : CALL LIRREE(FC,1,IRETOU) 79 : C 80 : IF(IRETOU.EQ.0) GOTO 666 81 : GO TO 10 82 : C 83 : 23 CONTINUE 84 : C LECTURE DE LA PUISSANCE DE LA FREQ 84 : CALL LIRENT(NPUIS,1,IRETOU) 85 : C 86 : IF(IRETOU.EQ.0) GOTO 666 87 : GO TO 10 88 : 89 : 12 CONTINUE 90 : C LECTURE DU TYPE DE SORTIE 90 : CALL LIRMOT(ISORT,2,ISOR,0) 91 : IF(ISOR.EQ.0) ISOR=2 92 : C 93 : GO TO 10 94 : C 95 : 13 CONTINUE 96 : C LECTURE DU PAS EN FREQUENCE 96 : CALL LIRREE(DF,1,IRETOU) 97 : C 98 : IF(IRETOU.EQ.0) GOTO 666 99 : GO TO 10 100 : C 101 : 30 CONTINUE 102 : IF(ITYP.EQ.0) THEN 103 : MOTERR(1:4)= MOCLE(1) 103 : CALL ERREUR ( 396 ) 104 : RETURN 105 : ENDIF 106 : C 107 : NPOINT=2**NN 108 : NPT2=NPOINT/2 109 : NP=NPT2+1 110 : C 111 : C CREATION DES FREQUENCES ET DU FILTRE 112 : C 113 : SEGINI TEMPP 114 : IF (ITYP.EQ.3) GO TO 100 115 : C 116 : C 117 : IF(ISOR.EQ.1) THEN 118 : C 119 : C SORTIE EN PARTIE REELLE & IMAGINAIRE 120 : C 121 : I=1 122 : XX(I)=0. 123 : IF (ITYP.EQ.1) THEN 124 : AA(I)=0. 125 : ELSE 126 : AA(I)=1. 127 : ENDIF 128 : BB(I)=0. 129 : DO 40 K=1,NPT2 130 : I=I+1 131 : FRQ=DBLE(I-1)*DF 132 : IF (ITYP.EQ.1) THEN 133 : RAP=FC/FRQ 134 : ELSE 135 : RAP=-FRQ/FC 136 : ENDIF 137 : DENOM=1./(1.+RAP*RAP) 138 : XX(I)=FRQ 139 : AA(I)=DENOM 140 : BB(I)=RAP*DENOM 141 : 40 CONTINUE 142 : C 143 : ELSE 144 : C 145 : C SORTIE EN MODULE & PHASE 146 : C 147 : I=1 148 : XX(I)=0. 149 : IF (ITYP.EQ.1) THEN 150 : AA(I)=0. 151 : BB(I)=90. 152 : ELSE 153 : AA(I)=1. 154 : BB(I)=0. 155 : ENDIF 156 : DO 50 K=1,NPT2 157 : I=I+1 158 : FRQ=DBLE(I-1)*DF 159 : IF (ITYP.EQ.1) THEN 160 : RAP=FC/FRQ 161 : ELSE 162 : RAP=FRQ/FC 163 : ENDIF 164 : DENOM=1./(1.+RAP*RAP) 165 : XX(I)=FRQ 166 : AA(I)=SQRT(DENOM) 167 : IF (ITYP.EQ.1) THEN 168 : BB(I)=ATAN(RAP)*DEGRES 169 : ELSE 170 : BB(I)=-ATAN(RAP)*DEGRES 171 : ENDIF 172 : 50 CONTINUE 173 : ENDIF 174 : C 175 : JG=NP 176 : SEGINI MLREE1,MLREE2,MLREE3 177 : C 178 : DO 60 I=1,NP 179 : MLREE1.PROG(I)=XX(I) 180 : MLREE2.PROG(I)=AA(I) 181 : MLREE3.PROG(I)=BB(I) 182 : 60 CONTINUE 183 : C 184 : GO TO 200 185 : 100 CONTINUE 186 : C 187 : IMULT = 1 188 : IF(NPUIS.LT.0) IMULT = -1 189 : C 190 : C 191 : MDPUIS = MOD ( (IMULT*NPUIS),4) 192 : IF(IMULT.EQ.-1) THEN 193 : MDPUI1 = MDPUIS 194 : IF(MDPUI1.EQ.1) MDPUIS = 3 195 : IF(MDPUI1.EQ.3) MDPUIS = 1 196 : ENDIF 197 : C 198 : IF (ISOR.EQ.1) THEN 199 : I=1 200 : XX(I)=0. 201 : AA(I)=0. 202 : BB(I)=0. 203 : OMEG(I)=0. 204 : DO 70 K=1,NPT2 205 : I=I+1 206 : FRQ=DBLE(I-1)*DF 207 : XX(I)=FRQ 208 : OMEG(I)=FRQ*XPI2 209 : 70 CONTINUE 210 : C 211 : C 212 : C 213 : IF (MDPUIS.EQ.0) THEN 214 : DO 71 K=2,NP 215 : AA(K)=OMEG(K)**NPUIS 216 : BB(K)=0. 217 : 71 CONTINUE 218 : ELSEIF (MDPUIS.EQ.1) THEN 219 : DO 72 K=2,NP 220 : AA(K)=0. 221 : BB(K)=(OMEG(K)**NPUIS) 222 : 72 CONTINUE 223 : ELSEIF (MDPUIS.EQ.2) THEN 224 : DO 73 K=2,NP 225 : AA(K)=-1.0*(OMEG(K)**NPUIS) 226 : BB(K)=0. 227 : 73 CONTINUE 228 : ELSEIF (MDPUIS.EQ.3) THEN 229 : DO 74 K=2,NP 230 : AA(K)=0. 231 : BB(K)=-1.0*(OMEG(K)**NPUIS) 232 : 74 CONTINUE 233 : ENDIF 234 : C 235 : ELSE 236 : I=1 237 : XX(I)=0. 238 : AA(I)=0. 239 : OMEG(I)=0. 240 : DO 75 K=1,NPT2 241 : I=I+1 242 : FRQ=DBLE(I-1)*DF 243 : XX(I)=FRQ 244 : OMEG(I)=FRQ*XPI2 245 : 75 CONTINUE 246 : C 247 : DO 81 K=2,NP 248 : AA(K)=OMEG(K)**NPUIS 249 : 81 CONTINUE 250 : IF (MDPUIS.EQ.1) THEN 251 : DO 76 K=1,NP 252 : BB(K)=90. 253 : 76 CONTINUE 254 : ELSEIF (MDPUIS.EQ.2) THEN 255 : DO 77 K=1,NP 256 : BB(K)=180. 257 : 77 CONTINUE 258 : ELSEIF (MDPUIS.EQ.3) THEN 259 : DO 78 K=1,NP 260 : BB(K)=-90. 261 : 78 CONTINUE 262 : ELSEIF (MDPUIS.EQ.0) THEN 263 : DO 79 K=1,NP 264 : BB(K)=0. 265 : 79 CONTINUE 266 : ENDIF 267 : C 268 : ENDIF 269 : C 270 : JG=NP 271 : SEGINI MLREE1,MLREE2,MLREE3 272 : C 273 : DO 80 I=1,NP 274 : MLREE1.PROG(I)=XX(I) 275 : MLREE2.PROG(I)=AA(I) 276 : MLREE3.PROG(I)=BB(I) 277 : 80 CONTINUE 278 : 200 CONTINUE 279 : SEGSUP TEMPP 280 : SEGDES MLREE1,MLREE2,MLREE3 281 : C 282 : C CREATION DE L'OBJET EVOLUTIO FILTRE 283 : C 284 : N=2 285 : SEGINI MEVOLL 286 : IPEVOL=MEVOLL 287 : C 288 : IEVTEX=TITREE 289 : ITYEVO='COMPLEXE' 290 : C 291 : C MODULE (OU PARTIE REELLE) 292 : C 293 : SEGINI KEVOL1 294 : KEVOL1.TYPX='LISTREEL' 295 : KEVOL1.TYPY='LISTREEL' 296 : IEVOLL(1)=KEVOL1 297 : C 298 : KEVOL1.KEVTEX=TITREE 299 : KEVOL1.NUMEVX=IDCOUL 300 : KEVOL1.NOMEVX='FREQUENCES ' 301 : IF(ISOR.EQ.1) THEN 302 : KEVOL1.NUMEVY='PREE' 303 : KEVOL1.NOMEVY='P. REELLE ' 304 : ELSE 305 : KEVOL1.NUMEVY='MODU' 306 : KEVOL1.NOMEVY='MODULE ' 307 : ENDIF 308 : KEVOL1.IPROGX=MLREE1 309 : KEVOL1.IPROGY=MLREE2 310 : KEVOL1.NUMEVX=IDCOUL 311 : SEGDES KEVOL1 312 : C 313 : C PHASE (OU PARTIE IMAGINAIRE) 314 : C 315 : SEGINI KEVOL2 316 : KEVOL2.TYPX='LISTREEL' 317 : KEVOL2.TYPY='LISTREEL' 318 : IEVOLL(2)=KEVOL2 319 : C 320 : KEVOL2.KEVTEX=TITREE 321 : KEVOL2.NUMEVX=IDCOUL 322 : KEVOL2.NOMEVX='FREQUENCES ' 323 : IF(ISOR.EQ.1) THEN 324 : KEVOL2.NUMEVY='PIMA' 325 : KEVOL2.NOMEVY='P.IMAGINAIRE' 326 : ELSE 327 : KEVOL2.NUMEVY='PHAS' 328 : KEVOL2.NOMEVY='PHASE ' 329 : ENDIF 330 : KEVOL2.IPROGX=MLREE1 331 : KEVOL2.IPROGY=MLREE3 332 : KEVOL2.NUMEVX=IDCOUL 333 : SEGDES KEVOL2 334 : C 335 : C 336 : SEGDES MEVOLL 336 : CALL ECROBJ('EVOLUTIO',IPEVOL) 337 : 666 CONTINUE 338 : RETURN 339 : END 340 : 341 : 342 : 343 : 344 : 345 : 346 : 347 : 348 :
© Cast3M 2003 - All rights reserved.
Disclaimer