source: lmdz_wrf/WRFV3/external/fftpack/fftpack5/r1fgkb.F @ 13

Last change on this file since 13 was 1, checked in by lfita, 11 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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