source: trunk/WRF.COMMON/WRFV3/external/fftpack/fftpack5/c1fgkf.F @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago

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