| blob | 1c92024bbe0dc6fc1d1b81fe26bb641abc921bfb |
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: cmfgkb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $
11 !
12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
14 SUBROUTINE CMFGKB (LOT,IDO,IP,L1,LID,NA,CC,CC1,IM1,IN1, &
15 & CH,CH1,IM2,IN2,WA)
16 REAL CH(2,IN2,L1,IDO,IP) ,CC(2,IN1,L1,IP,IDO), &
17 & CC1(2,IN1,LID,IP) ,CH1(2,IN2,LID,IP) , &
18 & WA(IDO,IP-1,2)
19 !
20 ! FFTPACK 5.0 auxiliary routine
21 !
22 M1D = (LOT-1)*IM1+1
23 M2S = 1-IM2
24 IPP2 = IP+2
25 IPPH = (IP+1)/2
26 DO 110 KI=1,LID
27 M2 = M2S
28 DO 110 M1=1,M1D,IM1
29 M2 = M2+IM2
30 CH1(1,M2,KI,1) = CC1(1,M1,KI,1)
31 CH1(2,M2,KI,1) = CC1(2,M1,KI,1)
32 110 CONTINUE
33 DO 111 J=2,IPPH
34 JC = IPP2-J
35 DO 112 KI=1,LID
36 M2 = M2S
37 DO 112 M1=1,M1D,IM1
38 M2 = M2+IM2
39 CH1(1,M2,KI,J) = CC1(1,M1,KI,J)+CC1(1,M1,KI,JC)
40 CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)-CC1(1,M1,KI,JC)
41 CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(2,M1,KI,JC)
42 CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(2,M1,KI,JC)
43 112 CONTINUE
44 111 END DO
45 DO 118 J=2,IPPH
46 DO 117 KI=1,LID
47 M2 = M2S
48 DO 117 M1=1,M1D,IM1
49 M2 = M2+IM2
50 CC1(1,M1,KI,1) = CC1(1,M1,KI,1)+CH1(1,M2,KI,J)
51 CC1(2,M1,KI,1) = CC1(2,M1,KI,1)+CH1(2,M2,KI,J)
52 117 CONTINUE
53 118 END DO
54 DO 116 L=2,IPPH
55 LC = IPP2-L
56 DO 113 KI=1,LID
57 M2 = M2S
58 DO 113 M1=1,M1D,IM1
59 M2 = M2+IM2
60 CC1(1,M1,KI,L) = CH1(1,M2,KI,1)+WA(1,L-1,1)*CH1(1,M2,KI,2)
61 CC1(1,M1,KI,LC) = WA(1,L-1,2)*CH1(1,M2,KI,IP)
62 CC1(2,M1,KI,L) = CH1(2,M2,KI,1)+WA(1,L-1,1)*CH1(2,M2,KI,2)
63 CC1(2,M1,KI,LC) = WA(1,L-1,2)*CH1(2,M2,KI,IP)
64 113 CONTINUE
65 DO 115 J=3,IPPH
66 JC = IPP2-J
67 IDLJ = MOD((L-1)*(J-1),IP)
68 WAR = WA(1,IDLJ,1)
69 WAI = WA(1,IDLJ,2)
70 DO 114 KI=1,LID
71 M2 = M2S
72 DO 114 M1=1,M1D,IM1
73 M2 = M2+IM2
74 CC1(1,M1,KI,L) = CC1(1,M1,KI,L)+WAR*CH1(1,M2,KI,J)
75 CC1(1,M1,KI,LC) = CC1(1,M1,KI,LC)+WAI*CH1(1,M2,KI,JC)
76 CC1(2,M1,KI,L) = CC1(2,M1,KI,L)+WAR*CH1(2,M2,KI,J)
77 CC1(2,M1,KI,LC) = CC1(2,M1,KI,LC)+WAI*CH1(2,M2,KI,JC)
78 114 CONTINUE
79 115 CONTINUE
80 116 END DO
81 IF(IDO.GT.1 .OR. NA.EQ.1) GO TO 136
82 DO 120 J=2,IPPH
83 JC = IPP2-J
84 DO 119 KI=1,LID
85 DO 119 M1=1,M1D,IM1
86 CHOLD1 = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC)
87 CHOLD2 = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC)
88 CC1(1,M1,KI,J) = CHOLD1
89 CC1(2,M1,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC)
90 CC1(2,M1,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC)
91 CC1(1,M1,KI,JC) = CHOLD2
92 119 CONTINUE
93 120 END DO
94 RETURN
95 136 DO 137 KI=1,LID
96 M2 = M2S
97 DO 137 M1=1,M1D,IM1
98 M2 = M2+IM2
99 CH1(1,M2,KI,1) = CC1(1,M1,KI,1)
100 CH1(2,M2,KI,1) = CC1(2,M1,KI,1)
101 137 CONTINUE
102 DO 135 J=2,IPPH
103 JC = IPP2-J
104 DO 134 KI=1,LID
105 M2 = M2S
106 DO 134 M1=1,M1D,IM1
107 M2 = M2+IM2
108 CH1(1,M2,KI,J) = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC)
109 CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC)
110 CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC)
111 CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC)
112 134 CONTINUE
113 135 END DO
114 IF (IDO .EQ. 1) RETURN
115 DO 131 I=1,IDO
116 DO 130 K=1,L1
117 M2 = M2S
118 DO 130 M1=1,M1D,IM1
119 M2 = M2+IM2
120 CC(1,M1,K,1,I) = CH(1,M2,K,I,1)
121 CC(2,M1,K,1,I) = CH(2,M2,K,I,1)
122 130 CONTINUE
123 131 END DO
124 DO 123 J=2,IP
125 DO 122 K=1,L1
126 M2 = M2S
127 DO 122 M1=1,M1D,IM1
128 M2 = M2+IM2
129 CC(1,M1,K,J,1) = CH(1,M2,K,1,J)
130 CC(2,M1,K,J,1) = CH(2,M2,K,1,J)
131 122 CONTINUE
132 123 END DO
133 DO 126 J=2,IP
134 DO 125 I=2,IDO
135 DO 124 K=1,L1
136 M2 = M2S
137 DO 124 M1=1,M1D,IM1
138 M2 = M2+IM2
139 CC(1,M1,K,J,I) = WA(I,J-1,1)*CH(1,M2,K,I,J) &
140 & -WA(I,J-1,2)*CH(2,M2,K,I,J)
141 CC(2,M1,K,J,I) = WA(I,J-1,1)*CH(2,M2,K,I,J) &
142 & +WA(I,J-1,2)*CH(1,M2,K,I,J)
143 124 CONTINUE
144 125 CONTINUE
145 126 END DO
146 RETURN
147 END