1*DECK RADBG
2      SUBROUTINE RADBG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA)
3C***BEGIN PROLOGUE  RADBG
4C***SUBSIDIARY
5C***PURPOSE  Calculate the fast Fourier transform of subvectors of
6C            arbitrary length.
7C***LIBRARY   SLATEC (FFTPACK)
8C***TYPE      SINGLE PRECISION (RADBG-S)
9C***AUTHOR  Swarztrauber, P. N., (NCAR)
10C***ROUTINES CALLED  (NONE)
11C***REVISION HISTORY  (YYMMDD)
12C   790601  DATE WRITTEN
13C   830401  Modified to use SLATEC library source file format.
14C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
15C           (a) changing dummy array size declarations (1) to (*),
16C           (b) changing references to intrinsic function FLOAT
17C               to REAL, and
18C           (c) changing definition of variable TPI by using
19C               FORTRAN intrinsic function ATAN instead of a DATA
20C               statement.
21C   881128  Modified by Dick Valent to meet prologue standards.
22C   890531  Changed all specific intrinsics to generic.  (WRB)
23C   890831  Modified array declarations.  (WRB)
24C   891214  Prologue converted to Version 4.0 format.  (BAB)
25C   900402  Added TYPE section.  (WRB)
26C***END PROLOGUE  RADBG
27      DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*),
28     +          C2(IDL1,*), CH2(IDL1,*), WA(*)
29C***FIRST EXECUTABLE STATEMENT  RADBG
30      TPI = 8.*ATAN(1.)
31      ARG = TPI/IP
32      DCP = COS(ARG)
33      DSP = SIN(ARG)
34      IDP2 = IDO+2
35      NBD = (IDO-1)/2
36      IPP2 = IP+2
37      IPPH = (IP+1)/2
38      IF (IDO .LT. L1) GO TO 103
39      DO 102 K=1,L1
40         DO 101 I=1,IDO
41            CH(I,K,1) = CC(I,1,K)
42  101    CONTINUE
43  102 CONTINUE
44      GO TO 106
45  103 DO 105 I=1,IDO
46         DO 104 K=1,L1
47            CH(I,K,1) = CC(I,1,K)
48  104    CONTINUE
49  105 CONTINUE
50  106 DO 108 J=2,IPPH
51         JC = IPP2-J
52         J2 = J+J
53         DO 107 K=1,L1
54            CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)
55            CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)
56  107    CONTINUE
57  108 CONTINUE
58      IF (IDO .EQ. 1) GO TO 116
59      IF (NBD .LT. L1) GO TO 112
60      DO 111 J=2,IPPH
61         JC = IPP2-J
62         DO 110 K=1,L1
63CDIR$ IVDEP
64            DO 109 I=3,IDO,2
65               IC = IDP2-I
66               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
67               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
68               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
69               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
70  109       CONTINUE
71  110    CONTINUE
72  111 CONTINUE
73      GO TO 116
74  112 DO 115 J=2,IPPH
75         JC = IPP2-J
76CDIR$ IVDEP
77         DO 114 I=3,IDO,2
78            IC = IDP2-I
79            DO 113 K=1,L1
80               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
81               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
82               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
83               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
84  113       CONTINUE
85  114    CONTINUE
86  115 CONTINUE
87  116 AR1 = 1.
88      AI1 = 0.
89      DO 120 L=2,IPPH
90         LC = IPP2-L
91         AR1H = DCP*AR1-DSP*AI1
92         AI1 = DCP*AI1+DSP*AR1
93         AR1 = AR1H
94         DO 117 IK=1,IDL1
95            C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)
96            C2(IK,LC) = AI1*CH2(IK,IP)
97  117    CONTINUE
98         DC2 = AR1
99         DS2 = AI1
100         AR2 = AR1
101         AI2 = AI1
102         DO 119 J=3,IPPH
103            JC = IPP2-J
104            AR2H = DC2*AR2-DS2*AI2
105            AI2 = DC2*AI2+DS2*AR2
106            AR2 = AR2H
107            DO 118 IK=1,IDL1
108               C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)
109               C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)
110  118       CONTINUE
111  119    CONTINUE
112  120 CONTINUE
113      DO 122 J=2,IPPH
114         DO 121 IK=1,IDL1
115            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
116  121    CONTINUE
117  122 CONTINUE
118      DO 124 J=2,IPPH
119         JC = IPP2-J
120         DO 123 K=1,L1
121            CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)
122            CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)
123  123    CONTINUE
124  124 CONTINUE
125      IF (IDO .EQ. 1) GO TO 132
126      IF (NBD .LT. L1) GO TO 128
127      DO 127 J=2,IPPH
128         JC = IPP2-J
129         DO 126 K=1,L1
130CDIR$ IVDEP
131            DO 125 I=3,IDO,2
132               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
133               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
134               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
135               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
136  125       CONTINUE
137  126    CONTINUE
138  127 CONTINUE
139      GO TO 132
140  128 DO 131 J=2,IPPH
141         JC = IPP2-J
142         DO 130 I=3,IDO,2
143            DO 129 K=1,L1
144               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
145               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
146               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
147               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
148  129       CONTINUE
149  130    CONTINUE
150  131 CONTINUE
151  132 CONTINUE
152      IF (IDO .EQ. 1) RETURN
153      DO 133 IK=1,IDL1
154         C2(IK,1) = CH2(IK,1)
155  133 CONTINUE
156      DO 135 J=2,IP
157         DO 134 K=1,L1
158            C1(1,K,J) = CH(1,K,J)
159  134    CONTINUE
160  135 CONTINUE
161      IF (NBD .GT. L1) GO TO 139
162      IS = -IDO
163      DO 138 J=2,IP
164         IS = IS+IDO
165         IDIJ = IS
166         DO 137 I=3,IDO,2
167            IDIJ = IDIJ+2
168            DO 136 K=1,L1
169               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
170               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
171  136       CONTINUE
172  137    CONTINUE
173  138 CONTINUE
174      GO TO 143
175  139 IS = -IDO
176      DO 142 J=2,IP
177         IS = IS+IDO
178         DO 141 K=1,L1
179            IDIJ = IS
180CDIR$ IVDEP
181            DO 140 I=3,IDO,2
182               IDIJ = IDIJ+2
183               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
184               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
185  140       CONTINUE
186  141    CONTINUE
187  142 CONTINUE
188  143 RETURN
189      END
190