1 : C TFOR SOURCE CHAT 07/10/29 21:29:33 5940 2 : SUBROUTINE TFOR(IOPT) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-V) 5 : IMPLICIT COMPLEX*16 (W-Z) 6 : CHARACTER *72 TI 7 : CHARACTER *24 MOTY 8 : CHARACTER *4 NSORT(2),MCLE(2) 9 : LOGICAL INV 10 : C 11 : C======================================================================= 12 : C = CALCUL DE LA TRANSFORMEE DE FOURIER RAPIDE D'UN SIGNAL = 13 : C = = 14 : C = SYNTAXE : = 15 : C = = 16 : C = TRANSFORMEE DE FOURIER DIRECTE (IOPT=-1) = 17 : C = FFTR = TFOR EXP2 EVO1 SORT FMIN V1 FMAX V2 (COU1) (COU2) ; = 18 : C = = 19 : C = TRANSFORMEE DE FOURIER INVERSE (IOPT=1) = 20 : C = FFTR = TFRI EXP2 EVO1 SORT FMIN V1 FMAX V2 (COU1) (COU2) ; = 21 : C = = 22 : C = = 23 : C = EXP2 : EXPOSANT DANS NPOINT=2^EXP2, NPOINT ETANT = 24 : C = LE NOMBRE DE REELS DANS LISTREEL = 25 : C = EVO1 : OBJET DE TYPE EVOLUTIO CONTENANT LE SIGNAL A TRAITER= 26 : C = SORT : TYPE DE SORTIE ; = 27 : C = = 'REIM' PART REEL & PART IMAG / FREQ = 28 : C = = 'MOPH' MODULE & PHASE / FREQ = 29 : C = FMIN : MOT-CLE = 30 : C = V1 : FREQUENCE MINIE A VISUALISER = 31 : C = FMAX : MOT-CLE = 32 : C = V2 : FREQUENCE MAXIE A VISUALISER = 33 : C = COU1 : COULEUR ATTRIBUEE A LA PREMIERE COURBE (FACULTATIF) = 34 : C = COU2 : COULEUR ATTRIBUEE A LA DEUXIEME COURBE (FACULTATIF) = 35 : C = = 36 : C = = 37 : C = CREATION : 16/04/87 = 38 : C = PROGRAMMEUR : BEAUFILS = 39 : C======================================================================= 40 : C 41 : -INC CCGEOME 42 : -INC CCOPTIO 43 : -INC SMEVOLL 44 : -INC SMLREEL 45 : C 46 : SEGMENT MTRAV1 47 : IMPLIED XX(NCOU),YY(NCOU) 48 : ENDSEGMENT 49 : C 50 : SEGMENT MTRAV2 51 : IMPLIED W(NEXP) 52 : ENDSEGMENT 53 : C 54 : DATA NSORT(1),NSORT(2)/'REIM','MOPH'/ 55 : DATA MCLE(1),MCLE(2)/'FMIN','FMAX'/ 56 : C 57 : C LECTURE DE EXP2 58 : C 58 : CALL LIRENT(N2,1,IRET1) 59 : IF(IRET1.EQ.0)GOTO 666 60 : C 61 : C LECTURE DE L'OBJET EVOLUTIO CONTENANT LE SIGNAL 62 : C 62 : CALL LIROBJ('EVOLUTIO',IPSIG,1,IRET2) 63 : IF(IRET2.EQ.0)GOTO 666 64 : C 65 : C LECTURE DU TYPE DE SORTIE 66 : C 66 : CALL LIRMOT(NSORT,2,ISORT,0) 67 : IF(ISORT.EQ.0) ISORT=1 68 : C 69 : C LECTURE DE LA FREQUENCE MINIE 70 : C 70 : CALL LIRMOT(MCLE(1),1,IRET,0) 71 : IF(IRET.EQ.1) THEN 71 : CALL LIRREE(FRMI,0,IRET1) 72 : IF(IRET1.EQ.0) THEN 73 : MOTERR(1:4)=MCLE(1)(1:4) 73 : CALL ERREUR(166) 74 : GOTO 666 75 : ENDIF 76 : IF(FRMI.LT.(-1.D-20)) FRMI=-FRMI 77 : IF(ABS(FRMI).LT.1.D-20) FRMA=-1.D0 78 : ELSE 79 : FRMI=-1.D0 80 : ENDIF 81 : C 82 : C LECTURE DE LA FREQUENCE MAXIE 83 : C 83 : CALL LIRMOT(MCLE(2),1,IRET,0) 84 : IF(IRET.EQ.1) THEN 84 : CALL LIRREE(FRMA,0,IRET1) 85 : IF(IRET1.EQ.0) THEN 86 : MOTERR(1:4)=MCLE(2)(1:4) 86 : CALL ERREUR(166) 87 : GOTO 666 88 : ENDIF 89 : IF(FRMA.LT.(-1.D-20)) FRMA=-FRMA 90 : IF(ABS(FRMA).LT.1.D-20) FRMA=-1.D0 91 : ELSE 92 : FRMA=-1.D0 93 : ENDIF 94 : C 95 : C LECTURE DE LA COULEUR 96 : C 96 : CALL LIRMOT(NCOUL,NBCOUL,ICOU1,0) 97 : IF (ICOU1.EQ.0) ICOU1=IDCOUL+1 98 : ICOU1=ICOU1-1 98 : CALL LIRMOT(NCOUL,NBCOUL,ICOU2,0) 99 : IF (ICOU2.EQ.0) ICOU2=IDCOUL+1 100 : ICOU2=ICOU2-1 101 : C 102 : IF(IERR.NE.0) GOTO 666 103 : C 104 : MEVOL1=IPSIG 105 : SEGACT MEVOL1 106 : KEVOL1=MEVOL1.IEVOLL(1) 107 : SEGACT KEVOL1 108 : MLREE1=KEVOL1.IPROGX 109 : MLREE2=KEVOL1.IPROGY 110 : C 111 : SEGACT MLREE1,MLREE2 112 : L1=MLREE1.PROG(/1) 113 : DT=MLREE1.PROG(2)-MLREE1.PROG(1) 114 : IF(DT.LE.0.) THEN 114 : CALL ERREUR(206) 115 : SEGDES MLREE1,MLREE2 116 : SEGDES KEVOL1,MEVOL1 117 : GO TO 666 118 : ENDIF 119 : SEGDES MLREE1 120 : C 121 : NPOINT=2**N2 122 : IF(NPOINT.GT.L1) THEN 123 : IF(IIMPI.EQ.1) WRITE(IOIMP,1000) L1,N2,NPOINT 124 : 1000 FORMAT(1H ,'LE NOMBRE DE POINTS DANS LISTEMPS ',I6, ' EST ', 125 : & 'INFERIEURE @ 2**',I5, 126 : & /' ON PRENDRA UNE LONGUEUR DE LISTEMPS DE ',I6,' MOTS ', 127 : & /' ET ON COMPLETERA PAR DES ZEROS') 128 : ELSE 129 : IF(NPOINT.LT.L1) THEN 130 : IF(IIMPI.EQ.1) WRITE(IOIMP,1010) N2 131 : 1010 FORMAT(1H ,'ON TRONQUE LE SIGNAL A 2**',I5,' MOTS',/) 132 : ELSE 133 : IF(IIMPI.EQ.1) WRITE(IOIMP,1030)N2,NPOINT 134 : 1030 FORMAT(1H ,'LA LONGUEUR DU LISTEMP EST EGALE A 2**',I5, 135 : & ' = ',I6,/) 136 : ENDIF 137 : ENDIF 138 : NDIBLK=NPOINT 139 : C 140 : NCOU=NPOINT 141 : SEGINI MTRAV1 142 : C 143 : NEXP=NPOINT/2 144 : SEGINI MTRAV2 145 : C 146 : C CHARGEMENT DES TABLEAUX DE TRAVAIL 147 : C 148 : IND1=L1 149 : IF(NPOINT.LT.L1)IND1 = NPOINT 150 : DO 10 I=1,IND1 151 : XX(I)=MLREE2.PROG(I) 152 : C IF(IIMPI.EQ.1)WRITE(IOIMP,*) ' XX(',I,') = ',XX(I) 153 : 10 CONTINUE 154 : IF(NPOINT.GT.L1) THEN 155 : L2=L1+1 156 : DO 11 I=L2,NPOINT 157 : XX(I)=0. 158 : 11 CONTINUE 159 : ENDIF 160 : C 161 : C CALCUL DE LA FFT 162 : C 163 : IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CALCUL DE LA FFT DU SIGNAL ' 164 : IF (IOPT.EQ.-1) THEN 165 : INV=.FALSE. 166 : ELSE 167 : INV=.TRUE. 168 : ENDIF 168 : CALL WEXP(INV,NPOINT,W(1)) 168 : CALL FFTL(XX(1),YY(1),W(1),NPOINT) 169 : C 170 : IF(IIMPI.EQ.1) WRITE(IOIMP,*)' FFT CALCULEE ' 171 : SEGDES MLREE2 172 : C 173 : C CREATION ET CALCUL DES LISTES DE LA FFT 174 : C 175 : IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CHARGEMENT DE LA FFT ' 176 : DUREE=DT*DBLE(NPOINT) 177 : DFREQ=1.D0/DUREE 178 : KHALF=INT(NPOINT/2)+1 179 : KMIN=INT(FRMI/DFREQ)+1 180 : KMAX=INT(FRMA/DFREQ)+1 181 : KDEBU=1 182 : IF(KMIN.GT.0) KDEBU=KMIN 183 : IF((KMAX.LT.KHALF).AND.(FRMA.GT.0.D0)) KHALF=KMAX 184 : NNN=KHALF-KDEBU+1 185 : JG=NNN 186 : SEGINI MLREE1 187 : SEGINI MLREE2 188 : SEGINI MLREE3 189 : IF(IIMPI.EQ.1) WRITE(IOIMP,*)' SORTIE DE ',NNN,' POINTS ' 190 : IF(ISORT.EQ.1) THEN 191 : C 192 : C SORTIE EN PARTIE REELLE & IMAGINAIRE / FREQUENCE 193 : C 194 : DO 20 I=KDEBU,KHALF 195 : FREQ=DBLE(I-1)*DFREQ 196 : C IF(IIMPI.EQ.1) WRITE(IOIMP,*)I,FREQ,' XX = ',XX(I) 197 : ITY=I-KDEBU+1 198 : MLREE1.PROG(ITY)=FREQ 199 : MLREE2.PROG(ITY)=DT*XX(I) 200 : MLREE3.PROG(ITY)=DT*CXTOIM(XX(I)) 201 : 20 CONTINUE 202 : MOTY(1:24)='PART REEL PART IMAG' 203 : ELSE 204 : C 205 : C SORTIE EN MODULE & PHASE / FREQUENCE 206 : C 207 : DO 21 I=KDEBU,KHALF 208 : FREQ=DBLE(I-1)*DFREQ 209 : C IF(IIMPI.EQ.1) WRITE(IOIMP,*)I,FREQ,' XX = ',XX(I) 210 : ITY=I-KDEBU+1 211 : MLREE1.PROG(ITY)=FREQ 212 : PREEL=XX(I) 213 : PIMAG=CXTOIM(XX(I)) 214 : PMODU=SQRT(PREEL*PREEL+PIMAG*PIMAG) 215 : MLREE2.PROG(ITY)=DT*PMODU 215 : CALL FACOMP(PREEL,PIMAG,PMODU) 216 : MLREE3.PROG(ITY)=PMODU 217 : 21 CONTINUE 218 : MOTY(1:8)='MODULE' 219 : MOTY(9:12)=' ' 220 : MOTY(13:20)='PHASE' 221 : MOTY(21:24)=' ' 222 : ENDIF 223 : C 224 : SEGDES MLREE1,MLREE2,MLREE3 225 : C 226 : C CREATION DE L'OBJET EVOLUTIO FFT 227 : C 228 : N=2 229 : SEGINI MEVOLL 230 : IPVO=MEVOLL 231 : TI(1:72)=TITREE 232 : IEVTEX=TI 233 : ITYEVO='COMPLEXE' 234 : C 235 : C PREMIERE COURBE 236 : C 237 : SEGINI KEVOLL 238 : TYPX='LISTREEL' 239 : TYPY='LISTREEL' 240 : KEVTEX=TI 241 : IEVOLL(1)=KEVOLL 242 : C 243 : IPROGX=MLREE1 244 : NOMEVX='FREQ HZ' 245 : C 246 : IPROGY=MLREE2 247 : NOMEVY=MOTY(1:12) 248 : C 249 : NUMEVX=ICOU1 250 : IF(ISORT.EQ.1) THEN 251 : NUMEVY='PREE' 252 : ELSE 253 : NUMEVY='MODU' 254 : ENDIF 255 : C 256 : SEGDES KEVOLL 257 : C 258 : C DEUXIEME COURBE 259 : C 260 : SEGINI KEVOLL 261 : TYPX='LISTREEL' 262 : TYPY='LISTREEL' 263 : KEVTEX=TI 264 : IEVOLL(2)=KEVOLL 265 : C 266 : IPROGX=MLREE1 267 : NOMEVX='FREQ HZ' 268 : C 269 : IPROGY=MLREE3 270 : NOMEVY=MOTY(13:24) 271 : C 272 : NUMEVX=ICOU2 273 : IF(ISORT.EQ.1) THEN 274 : NUMEVY='PIMA' 275 : ELSE 276 : NUMEVY='PHAS' 277 : ENDIF 278 : C 279 : SEGDES KEVOLL 280 : C 281 : SEGSUP MTRAV1,MTRAV2 282 : SEGDES KEVOL1,MEVOL1 283 : C 284 : SEGDES MEVOLL 284 : CALL ECROBJ('EVOLUTIO',IPVO) 285 : 666 CONTINUE 286 : RETURN 287 : END 288 : 289 : 290 : 291 : 292 : 293 : 294 : 295 : 296 :
© Cast3M 2003 - All rights reserved.
Disclaimer