source: flex_extract.git/src/grphreal.f @ b780393

ctbtodev
Last change on this file since b780393 was d69b677, checked in by Anne Philipp <bscannephilipp@…>, 6 years ago

original ECMWFDATA v7.0.2 from flexpart.eu

  • Property mode set to 100644
File size: 5.1 KB
Line 
1      MODULE GRTOPH
2
3      USE PHTOGR
4
5      CONTAINS
6C
7      SUBROUTINE GRPH213(CXMN,FELD,WSAVE,IFAX,Z,W,MLAT,
8     *MNAUF,MAXL,MAXB,MLEVEL)
9
10C     DIE ROUTINE F]HRT EINE TRANSFORMATION EINER
11C     FELDVARIABLEN VOM PHASENRAUM IN  DEN PHYSIKALISCHEN
12C     RAUM AUF KUGELKOORDINATEN DURCH
13C
14C     CXMN   = SPEKTRALKOEFFIZIENTEN IN DER REIHENFOLGE
15C              CX00,CX01,CX11,CX02,....CXMNAUFMNAUF
16C                       CXM              = FOURIERKOEFFIZIENTEN - nur ein Hilfsfeld
17C     FELD   = FELD DER METEOROLOGISCHEN VARIABLEN
18C                       WSAVE  = Working Array fuer Fouriertransformation
19C     Z          = LEGENDREFUNKTIONSWERTE
20C
21C     MNAUF    ANZAHL DER FOURIERKOEFFIZIENTEN
22C     MAXL     ANZAHL DER FUER DAS GITTER BENUTZTEN LAENGEN
23C     MAXB     ANZAHL DER FUER DAS GITTER BENOETIGTEN BREITEN
24C     MLEVEL   ANZAHL DER LEVELS, DIE TRANSFORMIERT WERDEN
25C
26      IMPLICIT REAL (A-H,O-Z)
27
28
29C                       Anzahl der Gitterpunkte pro Breitenkreis des reduzierten
30C                       Gauss'schen Gitters
31        INTEGER MLAT(MAXB),ISIZE,IFAX(10,MAXB)
32                       
33C    FELD DER LEGENDREPOLYNOME FUER EINE BREITE
34      REAL*8 Z(MAXB/2,0:((MNAUF+3)*(MNAUF+4))/2)
35     
36C      LOGICAL*1 USED(((216*217)/2+1)*160)
37
38      DIMENSION CXMN(0:(MNAUF+1)*(MNAUF+2)-1,MLEVEL)
39      REAL FELD(MAXL,MLEVEL)
40      DIMENSION WSAVE(8*MAXB+15,MAXB/2)
41      REAL*8 W(MAXB)
42      DIMENSION IND(MAXB)
43                       
44                       
45        IND(1)=0
46      DO 6 J=2,MAXB/2
47         IND(j)=IND(J-1)+MLAT(J-1)
48 6    CONTINUE
49!$OMP PARALLEL DO SCHEDULE(DYNAMIC)
50      DO 16 L=1,MLEVEL
51        CALL GRPHSUB(L,IND,CXMN,FELD,WSAVE,IFAX,Z,W,MLAT,
52     *MNAUF,MAXL,MAXB,MLEVEL)
5316    CONTINUE
54!$omp end parallel do
55
56
57      RETURN
58      END SUBROUTINE GRPH213
59C
60      SUBROUTINE GRPHSUB(L,IND,CXMN,FELD,WSAVE,IFAX,Z,W,MLAT,
61     *MNAUF,MAXL,MAXB,MLEVEL)
62
63C     DIE ROUTINE F]HRT EINE TRANSFORMATION EINER
64C     FELDVARIABLEN VOM PHASENRAUM IN  DEN PHYSIKALISCHEN
65C     RAUM AUF KUGELKOORDINATEN DURCH
66C
67C     CXMN   = SPEKTRALKOEFFIZIENTEN IN DER REIHENFOLGE
68C              CX00,CX01,CX11,CX02,....CXMNAUFMNAUF
69C                       CXM              = FOURIERKOEFFIZIENTEN - nur ein Hilfsfeld
70C     FELD   = FELD DER METEOROLOGISCHEN VARIABLEN
71C                       WSAVE  = Working Array fuer Fouriertransformation
72C     Z          = LEGENDREFUNKTIONSWERTE
73C
74C     MNAUF    ANZAHL DER FOURIERKOEFFIZIENTEN
75C     MAXL     ANZAHL DER FUER DAS GITTER BENUTZTEN LAENGEN
76C     MAXB     ANZAHL DER FUER DAS GITTER BENOETIGTEN BREITEN
77C     MLEVEL   ANZAHL DER LEVELS, DIE TRANSFORMIERT WERDEN
78C
79      IMPLICIT REAL (A-H,O-Z)
80
81C    FELD DER FOURIERKOEFFIZIENTEN
82      REAL CXMS(4*(MNAUF+1))
83      REAL CXMA(4*(MNAUF+1))
84      REAL,ALLOCATABLE :: CXM(:,:)
85
86C                       Anzahl der Gitterpunkte pro Breitenkreis des reduzierten
87C                       Gauss'schen Gitters
88                        INTEGER MLAT(MAXB),ISIZE
89                       
90C    FELD DER LEGENDREPOLYNOME FUER EINE BREITE
91      REAL Z(MAXB/2,0:((MNAUF+3)*(MNAUF+4))/2)
92     
93C      LOGICAL*1 USED(((216*217)/2+1)*160)
94
95      REAL CXMN(0:(MNAUF+1)*(MNAUF+2)-1,MLEVEL)
96      REAL FELD(MAXL,MLEVEL)
97      REAL WSAVE(8*MAXB+15,MAXB/2)
98      INTEGER IFAX(10,MAXB)
99      REAL W(MAXB)
100      INTEGER IND(MAXB)
101                       
102      ALLOCATE(CXM( 4*MAXB,MAXB))
103          DO 5 J=1,MAXB/2
104            CXMS(1:MLAT(J))=FELD(IND(J)+1:IND(J)+MLAT(J),L)
105            CALL RFOUFTR(CXMS,WSAVE(1,J),IFAX(:,J),MNAUF,MLAT(J),1)
106            CXMA(1:MLAT(J))=FELD(MAXL-IND(J)-MLAT(J)+1:MAXL-IND(J),L)
107            CALL RFOUFTR(CXMA,
108     *WSAVE(1,J),IFAX(:,J),MNAUF,MLAT(J),1)
109                DO 4 I=1,2*(MNAUF+1)
110                CXM(I,J)=CXMS(I)+CXMA(I)
111                CXM(I,MAXB+1-J)=CXMS(I)-CXMA(I)
1124                       CONTINUE
113    5   CONTINUE
114        CALL LGTR213(CXMN(0,L),CXM,Z,W,MLAT,MNAUF,MAXB)
115
116      DEALLOCATE(CXM)
117
118      RETURN
119      END SUBROUTINE GRPHSUB
120C
121        SUBROUTINE LGTR213(CXMN,CXM,Z,W,MLAT,MNAUF,MAXB)
122        IMPLICIT REAL (A-H,O-Z)
123        INTEGER MLAT(MAXB)
124        DIMENSION CXM(0:4*MAXB-1,MAXB)
125        DIMENSION CXMN(0:2*(((MNAUF+1)*MNAUF)/2+MNAUF)+1)
126        REAL*8 Z(MAXB/2,0:((MNAUF+3)*(MNAUF+4))/2)
127        REAL*8 W(MAXB),CR,CI,HILF
128        LOGICAL EVEN
129C
130C     DIESE ROUTINE BERECHNET DIE KFFKs CXMN
131C
132                        LL=0
133                        LLP=0
134      DO 1 I=0,MNAUF
135        KM=0
136    9   KM=KM+1
137        IF(MLAT(KM).LE.2*I) THEN
138           GOTO 9
139        ENDIF
140        DO 2 J=I,MNAUF
141          CR=0
142          CI=0
143          EVEN=MOD(I+J,2).EQ.0
144          IF(EVEN) THEN
145            DO 3 K=KM,MAXB/2
146                                  HILF=W(K)*Z(K,LLP)
147                      CR=CR+CXM(2*I,K)*HILF
148                      CI=CI+CXM(2*I+1,K)*HILF
149    3           CONTINUE
150          ELSE
151            DO 4 K=KM,MAXB/2
152                                  HILF=W(K)*Z(K,LLP)
153                      CR=CR+CXM(2*I,MAXB+1-K)*HILF
154                      CI=CI+CXM(2*I+1,MAXB+1-K)*HILF
155    4           CONTINUE
156          ENDIF
157    5     CXMN(2*LL)=CR
158          CXMN(2*LL+1)=CI
159          LL=LL+1
160          LLP=LLP+1
161    2   CONTINUE
162        LLP=LLP+2
163    1 CONTINUE
164        RETURN
165        END SUBROUTINE LGTR213
166C
167
168C
169      SUBROUTINE RFOUFTR(CXM,TRIGS,IFAX,MNAUF,MAXL,ISIGN)
170C     BERECHNET DIE FOURIERSUMME MIT EINEM FFT-ALGORITHMUS
171      IMPLICIT REAL (A-H,O-Z)
172      DIMENSION CXM(0:2*MAXL-1)
173      DIMENSION FELD(MAXL),TRIGS(2*MAXL)
174      DIMENSION WSAVE(MAXAUF)
175      INTEGER IFAX(10)
176
177
178C NORMIERUNG...
179      WSAVE(1)=CXM(MAXL-1)
180
181      CXM(1:MAXL)=CXM(0:MAXL-1)/2
182      CXM(0)=WSAVE(1)/2
183!      CALL CFFTF(MAXL,CXM,WSAVE)
184      CALL FFT99(CXM,WSAVE,TRIGS,IFAX,1,1,MAXL,1,-1)
185      RETURN
186      END SUBROUTINE RFOUFTR
187
188      END MODULE GRTOPH
Note: See TracBrowser for help on using the repository browser.
hosted by ZAMG