1 : C TFRINV SOURCE CHAT 05/01/13 03:37:11 5004 2 : SUBROUTINE TFRINV 3 : C 4 : C======================================================================= 5 : C = CALCUL DE LA TRANSFORMEE DE FOURIER INVERSE D'UN SIGNAL 6 : C = 7 : C = SYNTAXE : FFTR = TFRI EVOL ; 8 : C = 9 : C = EVOL : OBJET DE TYPE EVOLUTIO CONTENANT L'OBJET EVOLUTION 10 : C = = 11 : C = CREATION : 26/04/88 = 12 : C = F. ROULLIER 13 : C======================================================================= 14 : C 15 : IMPLICIT INTEGER(I-N) 16 : IMPLICIT REAL*8(A-H,O-Z) 17 : CHARACTER *72 TI 18 : CHARACTER *4 ITYP1 19 : COMPLEX*16 RLTOCX 20 : LOGICAL INV 21 : -INC CCOPTIO 22 : -INC SMEVOLL 23 : -INC SMLREEL 24 : C 25 : SEGMENT COMPL 26 : COMPLEX*16 XX(NPT),YY(NPT),W(NEXP) 27 : REAL*8 AX(NPT),AR(NPT),AI(NPT),AM(NPT),AP(NPT) 28 : IMPLIED DX(NPT),DR(NPT),DI(NPT),DM(NPT),DP(NPT) 29 : ENDSEGMENT 30 : C 31 : C LECTURE DE L'OBJET EVOLUTION COMPLEXE A TRANSFORMER 32 : C 32 : CALL LIROBJ('EVOLUTIO',IEV1,1,IRETOU) 33 : IF(IERR.NE.0) RETURN 34 : C 35 : MEVOLL=IEV1 36 : SEGACT MEVOLL 37 : IF (ITYEVO.NE.'COMPLEXE') THEN 38 : MOTERR(1:8)='EVOLUTION' 39 : SEGDES MEVOLL 39 : CALL ERREUR (302) 40 : RETURN 41 : ENDIF 42 : KEVOL1=IEVOLL(1) 43 : KEVOL2=IEVOLL(2) 44 : SEGACT KEVOL1,KEVOL2 45 : ITYP1=KEVOL1.NUMEVY 46 : ICOU1=KEVOL1.NUMEVX 47 : MLREE3=KEVOL1.IPROGX 48 : MLREE1=KEVOL1.IPROGY 49 : MLREE2=KEVOL2.IPROGY 50 : C 51 : SEGACT MLREE1,MLREE2,MLREE3 52 : L1=MLREE3.PROG(/1) 53 : DF=MLREE3.PROG(2)-MLREE3.PROG(1) 54 : SEGDES MLREE3 55 : C 56 : NPT=(L1-1)*2 57 : NP=NPT 58 : NN=0 59 : DO 1 I=1,1000 60 : NP=NP/2 61 : NN=NN+1 62 : IF (NP.LE.1) GO TO 2 63 : 1 CONTINUE 64 : 2 NP=2**NN 65 : IF (NP.NE.NPT) THEN 66 : WRITE(IOIMP,1000) 67 : 1000 FORMAT(1H ,' NOMBRE DE POINTS INCORECT ',3I6) 67 : CALL ERREUR (21) 68 : SEGDES MEVOLL,KEVOL1,KEVOL2 69 : SEGDES MLREE1,MLREE2 70 : RETURN 71 : ENDIF 72 : C 73 : NEXP=NPT/2 74 : NPOIN=L1 75 : SEGINI COMPL 76 : C 77 : C CHARGEMENT DES TABLEAUX DE TRAVAIL 78 : C 79 : IF (ITYP1.NE.'PREE') THEN 80 : DO 8 I=1,L1 81 : DM(I)=MLREE1.PROG(I) 82 : DP(I)=MLREE2.PROG(I) 83 : 8 CONTINUE 83 : CALL CONVCP(DR,DI,DM,DP,L1,-1) 84 : DO 7 I=1,L1 85 : AR(I)=DR(I) 86 : AI(I)=DI(I) 87 : 7 CONTINUE 88 : ELSE 89 : DO 9 I=1,L1 90 : AR(I)=MLREE1.PROG(I) 91 : AI(I)=MLREE2.PROG(I) 92 : 9 CONTINUE 93 : ENDIF 94 : J=NPT+1 95 : I=1 96 : XX(I)=RLTOCX(AR(I),AI(I)) 97 : L11=L1-1 98 : DO 10 II=2,L11 99 : I=I+1 100 : J=J-1 101 : XX(I)=RLTOCX(AR(I),AI(I)) 102 : XX(J)=RLTOCX(AR(I),-AI(I)) 103 : 10 CONTINUE 104 : XX(I+1)=RLTOCX(AR(I+1),AI(I+1)) 105 : C 106 : C CALCUL DE LA FFT INVERSE 107 : C 108 : INV=.TRUE. 108 : CALL WEXP(INV,NPT,W) 108 : CALL FFTL(XX,YY,W,NPT) 109 : C 110 : IF(IIMPI.EQ.1) WRITE(IOIMP,*)' FFT INVERSE CALCULEE ' 111 : SEGDES MLREE1,MLREE2 112 : SEGDES KEVOL1,KEVOL2 113 : SEGDES MEVOLL 114 : C 115 : C CREATION ET CALCUL DES LISTES DE LA FFT 116 : C 117 : JG=NPT 118 : SEGINI MLREE1,MLREE2 119 : FMAX=DF*DBLE(NPT) 120 : DTEMP=1.D0/FMAX 121 : C 122 : DO 20 I=1,NPT 123 : TEMP=DBLE(I-1)*DTEMP 124 : MLREE1.PROG(I)=TEMP 125 : MLREE2.PROG(I)=DF*XX(I) 126 : 20 CONTINUE 127 : SEGDES MLREE1,MLREE2 128 : C 129 : C CREATION DE L'OBJET EVOLUTION REEL FFT INVERSE 130 : C 131 : N=1 132 : SEGINI MEVOLL 133 : IPVO=MEVOLL 134 : IEVTEX=TITREE 135 : ITYEVO='REEL ' 136 : C 137 : SEGINI KEVOLL 138 : KEVTEX=TITREE 139 : TYPX='LISTREEL' 140 : TYPY='LISTREEL' 141 : IEVOLL(1)=KEVOLL 142 : IPROGX=MLREE1 143 : NOMEVX='TEMPS SEC' 144 : IPROGY=MLREE2 145 : NOMEVY='TF INVERSE ' 146 : NUMEVX=ICOU1 147 : NUMEVY='REEL' 148 : SEGDES KEVOLL,MEVOLL 149 : C 150 : SEGSUP COMPL 151 : C 151 : CALL ECROBJ('EVOLUTIO',IPVO) 152 : 666 CONTINUE 153 : RETURN 154 : END 155 : 156 : 157 : 158 :
© Cast3M 2003 - All rights reserved.
Disclaimer