source: trunk/WRF.COMMON/WRFV3/external/fftpack/fftpack5/r1fgkb.F @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 6.3 KB
Line 
1!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2!                                                                       
3!   FFTPACK 5.0                                                         
4!   Copyright (C) 1995-2004, Scientific Computing Division,             
5!   University Corporation for Atmospheric Research                     
6!   Licensed under the GNU General Public License (GPL)                 
7!                                                                       
8!   Authors:  Paul N. Swarztrauber and Richard A. Valent               
9!                                                                       
10!   $Id: r1fgkb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $               
11!                                                                       
12!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
13                                                                       
14      SUBROUTINE R1FGKB (IDO,IP,L1,IDL1,CC,C1,C2,IN1,                   &
15     &          CH,CH2,IN2,WA)                                         
16      REAL      CH(IN2,IDO,L1,IP)    ,CC(IN1,IDO,IP,L1) ,               &
17     &          C1(IN1,IDO,L1,IP)    ,C2(IN1,IDL1,IP),                  &
18     &          CH2(IN2,IDL1,IP)     ,WA(IDO)                           
19!                                                                       
20      TPI=2.*4.*ATAN(1.0)
21      ARG = TPI/FLOAT(IP)
22      DCP = COS(ARG)
23      DSP = SIN(ARG)
24      IDP2 = IDO+2
25      NBD = (IDO-1)/2
26      IPP2 = IP+2
27      IPPH = (IP+1)/2
28      IF (IDO .LT. L1) GO TO 103
29      DO 102 K=1,L1
30         DO 101 I=1,IDO
31            CH(1,I,K,1) = CC(1,I,1,K)
32  101    CONTINUE
33  102 END DO
34      GO TO 106
35  103 DO 105 I=1,IDO
36         DO 104 K=1,L1
37            CH(1,I,K,1) = CC(1,I,1,K)
38  104    CONTINUE
39  105 END DO
40  106 DO 108 J=2,IPPH
41         JC = IPP2-J
42         J2 = J+J
43         DO 107 K=1,L1
44            CH(1,1,K,J) = CC(1,IDO,J2-2,K)+CC(1,IDO,J2-2,K)
45            CH(1,1,K,JC) = CC(1,1,J2-1,K)+CC(1,1,J2-1,K)
46 1007       CONTINUE
47  107    CONTINUE
48  108 END DO
49      IF (IDO .EQ. 1) GO TO 116
50      IF (NBD .LT. L1) GO TO 112
51      DO 111 J=2,IPPH
52         JC = IPP2-J
53         DO 110 K=1,L1
54            DO 109 I=3,IDO,2
55               IC = IDP2-I
56               CH(1,I-1,K,J) = CC(1,I-1,2*J-1,K)+CC(1,IC-1,2*J-2,K)
57               CH(1,I-1,K,JC) = CC(1,I-1,2*J-1,K)-CC(1,IC-1,2*J-2,K)
58               CH(1,I,K,J) = CC(1,I,2*J-1,K)-CC(1,IC,2*J-2,K)
59               CH(1,I,K,JC) = CC(1,I,2*J-1,K)+CC(1,IC,2*J-2,K)
60  109       CONTINUE
61  110    CONTINUE
62  111 END DO
63      GO TO 116
64  112 DO 115 J=2,IPPH
65         JC = IPP2-J
66         DO 114 I=3,IDO,2
67            IC = IDP2-I
68            DO 113 K=1,L1
69               CH(1,I-1,K,J) = CC(1,I-1,2*J-1,K)+CC(1,IC-1,2*J-2,K)
70               CH(1,I-1,K,JC) = CC(1,I-1,2*J-1,K)-CC(1,IC-1,2*J-2,K)
71               CH(1,I,K,J) = CC(1,I,2*J-1,K)-CC(1,IC,2*J-2,K)
72               CH(1,I,K,JC) = CC(1,I,2*J-1,K)+CC(1,IC,2*J-2,K)
73  113       CONTINUE
74  114    CONTINUE
75  115 END DO
76  116 AR1 = 1.
77      AI1 = 0.
78      DO 120 L=2,IPPH
79         LC = IPP2-L
80         AR1H = DCP*AR1-DSP*AI1
81         AI1 = DCP*AI1+DSP*AR1
82         AR1 = AR1H
83         DO 117 IK=1,IDL1
84            C2(1,IK,L) = CH2(1,IK,1)+AR1*CH2(1,IK,2)
85            C2(1,IK,LC) = AI1*CH2(1,IK,IP)
86  117    CONTINUE
87         DC2 = AR1
88         DS2 = AI1
89         AR2 = AR1
90         AI2 = AI1
91         DO 119 J=3,IPPH
92            JC = IPP2-J
93            AR2H = DC2*AR2-DS2*AI2
94            AI2 = DC2*AI2+DS2*AR2
95            AR2 = AR2H
96            DO 118 IK=1,IDL1
97               C2(1,IK,L) = C2(1,IK,L)+AR2*CH2(1,IK,J)
98               C2(1,IK,LC) = C2(1,IK,LC)+AI2*CH2(1,IK,JC)
99  118       CONTINUE
100  119    CONTINUE
101  120 END DO
102      DO 122 J=2,IPPH
103         DO 121 IK=1,IDL1
104            CH2(1,IK,1) = CH2(1,IK,1)+CH2(1,IK,J)
105  121    CONTINUE
106  122 END DO
107      DO 124 J=2,IPPH
108         JC = IPP2-J
109         DO 123 K=1,L1
110            CH(1,1,K,J) = C1(1,1,K,J)-C1(1,1,K,JC)
111            CH(1,1,K,JC) = C1(1,1,K,J)+C1(1,1,K,JC)
112  123    CONTINUE
113  124 END DO
114      IF (IDO .EQ. 1) GO TO 132
115      IF (NBD .LT. L1) GO TO 128
116      DO 127 J=2,IPPH
117         JC = IPP2-J
118         DO 126 K=1,L1
119            DO 125 I=3,IDO,2
120               CH(1,I-1,K,J) = C1(1,I-1,K,J)-C1(1,I,K,JC)
121               CH(1,I-1,K,JC) = C1(1,I-1,K,J)+C1(1,I,K,JC)
122               CH(1,I,K,J) = C1(1,I,K,J)+C1(1,I-1,K,JC)
123               CH(1,I,K,JC) = C1(1,I,K,J)-C1(1,I-1,K,JC)
124  125       CONTINUE
125  126    CONTINUE
126  127 END DO
127      GO TO 132
128  128 DO 131 J=2,IPPH
129         JC = IPP2-J
130         DO 130 I=3,IDO,2
131            DO 129 K=1,L1
132               CH(1,I-1,K,J) = C1(1,I-1,K,J)-C1(1,I,K,JC)
133               CH(1,I-1,K,JC) = C1(1,I-1,K,J)+C1(1,I,K,JC)
134               CH(1,I,K,J) = C1(1,I,K,J)+C1(1,I-1,K,JC)
135               CH(1,I,K,JC) = C1(1,I,K,J)-C1(1,I-1,K,JC)
136  129       CONTINUE
137  130    CONTINUE
138  131 END DO
139  132 CONTINUE
140      IF (IDO .EQ. 1) RETURN
141      DO 133 IK=1,IDL1
142         C2(1,IK,1) = CH2(1,IK,1)
143  133 END DO
144      DO 135 J=2,IP
145         DO 134 K=1,L1
146            C1(1,1,K,J) = CH(1,1,K,J)
147  134    CONTINUE
148  135 END DO
149      IF (NBD .GT. L1) GO TO 139
150      IS = -IDO
151      DO 138 J=2,IP
152         IS = IS+IDO
153         IDIJ = IS
154         DO 137 I=3,IDO,2
155            IDIJ = IDIJ+2
156            DO 136 K=1,L1
157               C1(1,I-1,K,J) = WA(IDIJ-1)*CH(1,I-1,K,J)-WA(IDIJ)*       &
158     &          CH(1,I,K,J)                                             
159               C1(1,I,K,J) = WA(IDIJ-1)*CH(1,I,K,J)+WA(IDIJ)*           &
160     &          CH(1,I-1,K,J)                                           
161  136       CONTINUE
162  137    CONTINUE
163  138 END DO
164      GO TO 143
165  139 IS = -IDO
166      DO 142 J=2,IP
167         IS = IS+IDO
168         DO 141 K=1,L1
169            IDIJ = IS
170            DO 140 I=3,IDO,2
171               IDIJ = IDIJ+2
172               C1(1,I-1,K,J) = WA(IDIJ-1)*CH(1,I-1,K,J)-WA(IDIJ)*       &
173     &          CH(1,I,K,J)                                             
174               C1(1,I,K,J) = WA(IDIJ-1)*CH(1,I,K,J)+WA(IDIJ)*           &
175     &          CH(1,I-1,K,J)                                           
176  140       CONTINUE
177  141    CONTINUE
178  142 END DO
179  143 RETURN
180      END                                           
Note: See TracBrowser for help on using the repository browser.