1*DECK PASSB
2      SUBROUTINE PASSB (NAC, IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA)
3C***BEGIN PROLOGUE  PASSB
4C***SUBSIDIARY
5C***PURPOSE  Calculate the fast Fourier transform of subvectors of
6C            arbitrary length.
7C***LIBRARY   SLATEC (FFTPACK)
8C***TYPE      SINGLE PRECISION (PASSB-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           changing dummy array size declarations (1) to (*).
16C   881128  Modified by Dick Valent to meet prologue standards.
17C   890831  Modified array declarations.  (WRB)
18C   891009  Removed unreferenced variable.  (WRB)
19C   891214  Prologue converted to Version 4.0 format.  (BAB)
20C   900402  Added TYPE section.  (WRB)
21C***END PROLOGUE  PASSB
22      DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), WA(*),
23     +          C2(IDL1,*), CH2(IDL1,*)
24C***FIRST EXECUTABLE STATEMENT  PASSB
25      IDOT = IDO/2
26      IPP2 = IP+2
27      IPPH = (IP+1)/2
28      IDP = IP*IDO
29C
30      IF (IDO .LT. L1) GO TO 106
31      DO 103 J=2,IPPH
32         JC = IPP2-J
33         DO 102 K=1,L1
34CDIR$ IVDEP
35            DO 101 I=1,IDO
36               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
37               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
38  101       CONTINUE
39  102    CONTINUE
40  103 CONTINUE
41      DO 105 K=1,L1
42CDIR$ IVDEP
43         DO 104 I=1,IDO
44            CH(I,K,1) = CC(I,1,K)
45  104    CONTINUE
46  105 CONTINUE
47      GO TO 112
48  106 DO 109 J=2,IPPH
49         JC = IPP2-J
50         DO 108 I=1,IDO
51CDIR$ IVDEP
52            DO 107 K=1,L1
53               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
54               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
55  107       CONTINUE
56  108    CONTINUE
57  109 CONTINUE
58      DO 111 I=1,IDO
59CDIR$ IVDEP
60         DO 110 K=1,L1
61            CH(I,K,1) = CC(I,1,K)
62  110    CONTINUE
63  111 CONTINUE
64  112 IDL = 2-IDO
65      INC = 0
66      DO 116 L=2,IPPH
67         LC = IPP2-L
68         IDL = IDL+IDO
69CDIR$ IVDEP
70         DO 113 IK=1,IDL1
71            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
72            C2(IK,LC) = WA(IDL)*CH2(IK,IP)
73  113    CONTINUE
74         IDLJ = IDL
75         INC = INC+IDO
76         DO 115 J=3,IPPH
77            JC = IPP2-J
78            IDLJ = IDLJ+INC
79            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
80            WAR = WA(IDLJ-1)
81            WAI = WA(IDLJ)
82CDIR$ IVDEP
83            DO 114 IK=1,IDL1
84               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
85               C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)
86  114       CONTINUE
87  115    CONTINUE
88  116 CONTINUE
89      DO 118 J=2,IPPH
90CDIR$ IVDEP
91         DO 117 IK=1,IDL1
92            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
93  117    CONTINUE
94  118 CONTINUE
95      DO 120 J=2,IPPH
96         JC = IPP2-J
97CDIR$ IVDEP
98         DO 119 IK=2,IDL1,2
99            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
100            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
101            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
102            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
103  119    CONTINUE
104  120 CONTINUE
105      NAC = 1
106      IF (IDO .EQ. 2) RETURN
107      NAC = 0
108      DO 121 IK=1,IDL1
109         C2(IK,1) = CH2(IK,1)
110  121 CONTINUE
111      DO 123 J=2,IP
112CDIR$ IVDEP
113         DO 122 K=1,L1
114            C1(1,K,J) = CH(1,K,J)
115            C1(2,K,J) = CH(2,K,J)
116  122    CONTINUE
117  123 CONTINUE
118      IF (IDOT .GT. L1) GO TO 127
119      IDIJ = 0
120      DO 126 J=2,IP
121         IDIJ = IDIJ+2
122         DO 125 I=4,IDO,2
123            IDIJ = IDIJ+2
124CDIR$ IVDEP
125            DO 124 K=1,L1
126               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
127               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
128  124       CONTINUE
129  125    CONTINUE
130  126 CONTINUE
131      RETURN
132  127 IDJ = 2-IDO
133      DO 130 J=2,IP
134         IDJ = IDJ+IDO
135         DO 129 K=1,L1
136            IDIJ = IDJ
137CDIR$ IVDEP
138            DO 128 I=4,IDO,2
139               IDIJ = IDIJ+2
140               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
141               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
142  128       CONTINUE
143  129    CONTINUE
144  130 CONTINUE
145      RETURN
146      END
147