| blob | 1294a61aad32f3b56de9c4c38164d6000ec4d1d2 |
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
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