1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
subroutine passf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
implicit double precision (a-h,o-z)
dimension ch(ido,l1,ip) ,cc(ido,ip,l1) ,
1 c1(ido,l1,ip) ,wa(1) ,c2(idl1,ip),
2 ch2(idl1,ip)
idot = ido/2
nt = ip*idl1
ipp2 = ip+2
ipph = (ip+1)/2
idp = ip*ido
c
if (ido .lt. l1) go to 106
do 103 j=2,ipph
jc = ipp2-j
do 102 k=1,l1
do 101 i=1,ido
ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
101 continue
102 continue
103 continue
do 105 k=1,l1
do 104 i=1,ido
ch(i,k,1) = cc(i,1,k)
104 continue
105 continue
go to 112
106 do 109 j=2,ipph
jc = ipp2-j
do 108 i=1,ido
do 107 k=1,l1
ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
107 continue
108 continue
109 continue
do 111 i=1,ido
do 110 k=1,l1
ch(i,k,1) = cc(i,1,k)
110 continue
111 continue
112 idl = 2-ido
inc = 0
do 116 l=2,ipph
lc = ipp2-l
idl = idl+ido
do 113 ik=1,idl1
c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2)
c2(ik,lc) = -wa(idl)*ch2(ik,ip)
113 continue
idlj = idl
inc = inc+ido
do 115 j=3,ipph
jc = ipp2-j
idlj = idlj+inc
if (idlj .gt. idp) idlj = idlj-idp
war = wa(idlj-1)
wai = wa(idlj)
do 114 ik=1,idl1
c2(ik,l) = c2(ik,l)+war*ch2(ik,j)
c2(ik,lc) = c2(ik,lc)-wai*ch2(ik,jc)
114 continue
115 continue
116 continue
do 118 j=2,ipph
do 117 ik=1,idl1
ch2(ik,1) = ch2(ik,1)+ch2(ik,j)
117 continue
118 continue
do 120 j=2,ipph
jc = ipp2-j
do 119 ik=2,idl1,2
ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc)
ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc)
ch2(ik,j) = c2(ik,j)+c2(ik-1,jc)
ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc)
119 continue
120 continue
nac = 1
if (ido .eq. 2) return
nac = 0
do 121 ik=1,idl1
c2(ik,1) = ch2(ik,1)
121 continue
do 123 j=2,ip
do 122 k=1,l1
c1(1,k,j) = ch(1,k,j)
c1(2,k,j) = ch(2,k,j)
122 continue
123 continue
if (idot .gt. l1) go to 127
idij = 0
do 126 j=2,ip
idij = idij+2
do 125 i=4,ido,2
idij = idij+2
do 124 k=1,l1
c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j)
c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j)
124 continue
125 continue
126 continue
return
127 idj = 2-ido
do 130 j=2,ip
idj = idj+ido
do 129 k=1,l1
idij = idj
do 128 i=4,ido,2
idij = idij+2
c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j)
c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j)
128 continue
129 continue
130 continue
return
end
|
