source: trunk/WRF.COMMON/WRFV3/external/fftpack/fftpack5/r1fgkf.F

Last change on this file 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.4 KB
RevLine 
[2759]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: r1fgkf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $               
11!                                                                       
12!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
13                                                                       
14      SUBROUTINE R1FGKF (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      IPPH = (IP+1)/2
25      IPP2 = IP+2
26      IDP2 = IDO+2
27      NBD = (IDO-1)/2
28      IF (IDO .EQ. 1) GO TO 119
29      DO 101 IK=1,IDL1
30         CH2(1,IK,1) = C2(1,IK,1)
31  101 END DO
32      DO 103 J=2,IP
33         DO 102 K=1,L1
34            CH(1,1,K,J) = C1(1,1,K,J)
35  102    CONTINUE
36  103 END DO
37      IF (NBD .GT. L1) GO TO 107
38      IS = -IDO
39      DO 106 J=2,IP
40         IS = IS+IDO
41         IDIJ = IS
42         DO 105 I=3,IDO,2
43            IDIJ = IDIJ+2
44            DO 104 K=1,L1
45               CH(1,I-1,K,J) = WA(IDIJ-1)*C1(1,I-1,K,J)+WA(IDIJ)        &
46     &           *C1(1,I,K,J)                                           
47               CH(1,I,K,J) = WA(IDIJ-1)*C1(1,I,K,J)-WA(IDIJ)            &
48     &           *C1(1,I-1,K,J)                                         
49  104       CONTINUE
50  105    CONTINUE
51  106 END DO
52      GO TO 111
53  107 IS = -IDO
54      DO 110 J=2,IP
55         IS = IS+IDO
56         DO 109 K=1,L1
57            IDIJ = IS
58            DO 108 I=3,IDO,2
59               IDIJ = IDIJ+2
60               CH(1,I-1,K,J) = WA(IDIJ-1)*C1(1,I-1,K,J)+WA(IDIJ)        &
61     &           *C1(1,I,K,J)                                           
62               CH(1,I,K,J) = WA(IDIJ-1)*C1(1,I,K,J)-WA(IDIJ)            &
63     &           *C1(1,I-1,K,J)                                         
64  108       CONTINUE
65  109    CONTINUE
66  110 END DO
67  111 IF (NBD .LT. L1) GO TO 115
68      DO 114 J=2,IPPH
69         JC = IPP2-J
70         DO 113 K=1,L1
71            DO 112 I=3,IDO,2
72               C1(1,I-1,K,J) = CH(1,I-1,K,J)+CH(1,I-1,K,JC)
73               C1(1,I-1,K,JC) = CH(1,I,K,J)-CH(1,I,K,JC)
74               C1(1,I,K,J) = CH(1,I,K,J)+CH(1,I,K,JC)
75               C1(1,I,K,JC) = CH(1,I-1,K,JC)-CH(1,I-1,K,J)
76  112       CONTINUE
77  113    CONTINUE
78  114 END DO
79      GO TO 121
80  115 DO 118 J=2,IPPH
81         JC = IPP2-J
82         DO 117 I=3,IDO,2
83            DO 116 K=1,L1
84               C1(1,I-1,K,J) = CH(1,I-1,K,J)+CH(1,I-1,K,JC)
85               C1(1,I-1,K,JC) = CH(1,I,K,J)-CH(1,I,K,JC)
86               C1(1,I,K,J) = CH(1,I,K,J)+CH(1,I,K,JC)
87               C1(1,I,K,JC) = CH(1,I-1,K,JC)-CH(1,I-1,K,J)
88  116       CONTINUE
89  117    CONTINUE
90  118 END DO
91      GO TO 121
92  119 DO 120 IK=1,IDL1
93         C2(1,IK,1) = CH2(1,IK,1)
94  120 END DO
95  121 DO 123 J=2,IPPH
96         JC = IPP2-J
97         DO 122 K=1,L1
98            C1(1,1,K,J) = CH(1,1,K,J)+CH(1,1,K,JC)
99            C1(1,1,K,JC) = CH(1,1,K,JC)-CH(1,1,K,J)
100  122    CONTINUE
101  123 END DO
102!                                                                       
103      AR1 = 1.
104      AI1 = 0.
105      DO 127 L=2,IPPH
106         LC = IPP2-L
107         AR1H = DCP*AR1-DSP*AI1
108         AI1 = DCP*AI1+DSP*AR1
109         AR1 = AR1H
110         DO 124 IK=1,IDL1
111            CH2(1,IK,L) = C2(1,IK,1)+AR1*C2(1,IK,2)
112            CH2(1,IK,LC) = AI1*C2(1,IK,IP)
113  124    CONTINUE
114         DC2 = AR1
115         DS2 = AI1
116         AR2 = AR1
117         AI2 = AI1
118         DO 126 J=3,IPPH
119            JC = IPP2-J
120            AR2H = DC2*AR2-DS2*AI2
121            AI2 = DC2*AI2+DS2*AR2
122            AR2 = AR2H
123            DO 125 IK=1,IDL1
124               CH2(1,IK,L) = CH2(1,IK,L)+AR2*C2(1,IK,J)
125               CH2(1,IK,LC) = CH2(1,IK,LC)+AI2*C2(1,IK,JC)
126  125       CONTINUE
127  126    CONTINUE
128  127 END DO
129      DO 129 J=2,IPPH
130         DO 128 IK=1,IDL1
131            CH2(1,IK,1) = CH2(1,IK,1)+C2(1,IK,J)
132  128    CONTINUE
133  129 END DO
134!                                                                       
135      IF (IDO .LT. L1) GO TO 132
136      DO 131 K=1,L1
137         DO 130 I=1,IDO
138            CC(1,I,1,K) = CH(1,I,K,1)
139  130    CONTINUE
140  131 END DO
141      GO TO 135
142  132 DO 134 I=1,IDO
143         DO 133 K=1,L1
144            CC(1,I,1,K) = CH(1,I,K,1)
145  133    CONTINUE
146  134 END DO
147  135 DO 137 J=2,IPPH
148         JC = IPP2-J
149         J2 = J+J
150         DO 136 K=1,L1
151            CC(1,IDO,J2-2,K) = CH(1,1,K,J)
152            CC(1,1,J2-1,K) = CH(1,1,K,JC)
153  136    CONTINUE
154  137 END DO
155      IF (IDO .EQ. 1) RETURN
156      IF (NBD .LT. L1) GO TO 141
157      DO 140 J=2,IPPH
158         JC = IPP2-J
159         J2 = J+J
160         DO 139 K=1,L1
161            DO 138 I=3,IDO,2
162               IC = IDP2-I
163               CC(1,I-1,J2-1,K) = CH(1,I-1,K,J)+CH(1,I-1,K,JC)
164               CC(1,IC-1,J2-2,K) = CH(1,I-1,K,J)-CH(1,I-1,K,JC)
165               CC(1,I,J2-1,K) = CH(1,I,K,J)+CH(1,I,K,JC)
166               CC(1,IC,J2-2,K) = CH(1,I,K,JC)-CH(1,I,K,J)
167  138       CONTINUE
168  139    CONTINUE
169  140 END DO
170      RETURN
171  141 DO 144 J=2,IPPH
172         JC = IPP2-J
173         J2 = J+J
174         DO 143 I=3,IDO,2
175            IC = IDP2-I
176            DO 142 K=1,L1
177               CC(1,I-1,J2-1,K) = CH(1,I-1,K,J)+CH(1,I-1,K,JC)
178               CC(1,IC-1,J2-2,K) = CH(1,I-1,K,J)-CH(1,I-1,K,JC)
179               CC(1,I,J2-1,K) = CH(1,I,K,J)+CH(1,I,K,JC)
180               CC(1,IC,J2-2,K) = CH(1,I,K,JC)-CH(1,I,K,J)
181  142       CONTINUE
182  143    CONTINUE
183  144 END DO
184      RETURN
185      END                                           
Note: See TracBrowser for help on using the repository browser.