source: trunk/WRF.COMMON/WRFV3/external/fftpack/fftpack5/r1f5kb.F

Last change on this file 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: 7.7 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: r1f5kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $               
11!                                                                       
12!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
13                                                                       
14      SUBROUTINE R1F5KB (IDO,L1,CC,IN1,CH,IN2,                          &
15     &       WA1,WA2,WA3,WA4)                                           
16      REAL   CC(IN1,IDO,5,L1)    ,CH(IN2,IDO,L1,5),                     &
17     &       WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)         
18!                                                                       
19      ARG=2.*4.*ATAN(1.0)/5.
20      TR11=COS(ARG)
21      TI11=SIN(ARG)
22      TR12=COS(2.*ARG)
23      TI12=SIN(2.*ARG)
24      DO 101 K=1,L1
25         CH(1,1,K,1) = CC(1,1,1,K)+2.*CC(1,IDO,2,K)+2.*CC(1,IDO,4,K)
26         CH(1,1,K,2) = (CC(1,1,1,K)+TR11*2.*CC(1,IDO,2,K)               &
27     &   +TR12*2.*CC(1,IDO,4,K))-(TI11*2.*CC(1,1,3,K)                   &
28     &   +TI12*2.*CC(1,1,5,K))                                         
29         CH(1,1,K,3) = (CC(1,1,1,K)+TR12*2.*CC(1,IDO,2,K)               &
30     &   +TR11*2.*CC(1,IDO,4,K))-(TI12*2.*CC(1,1,3,K)                   &
31     &   -TI11*2.*CC(1,1,5,K))                                         
32         CH(1,1,K,4) = (CC(1,1,1,K)+TR12*2.*CC(1,IDO,2,K)               &
33     &   +TR11*2.*CC(1,IDO,4,K))+(TI12*2.*CC(1,1,3,K)                   &
34     &   -TI11*2.*CC(1,1,5,K))                                         
35         CH(1,1,K,5) = (CC(1,1,1,K)+TR11*2.*CC(1,IDO,2,K)               &
36     &   +TR12*2.*CC(1,IDO,4,K))+(TI11*2.*CC(1,1,3,K)                   &
37     &   +TI12*2.*CC(1,1,5,K))                                         
38  101 END DO
39      IF (IDO .EQ. 1) RETURN
40      IDP2 = IDO+2
41      DO 103 K=1,L1
42         DO 102 I=3,IDO,2
43            IC = IDP2-I
44        CH(1,I-1,K,1) = CC(1,I-1,1,K)+(CC(1,I-1,3,K)+CC(1,IC-1,2,K))    &
45     &  +(CC(1,I-1,5,K)+CC(1,IC-1,4,K))                                 
46        CH(1,I,K,1) = CC(1,I,1,K)+(CC(1,I,3,K)-CC(1,IC,2,K))            &
47     &  +(CC(1,I,5,K)-CC(1,IC,4,K))                                     
48        CH(1,I-1,K,2) = WA1(I-2)*((CC(1,I-1,1,K)+TR11*                  &
49     &  (CC(1,I-1,3,K)+CC(1,IC-1,2,K))+TR12                             &
50     &  *(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI11*(CC(1,I,3,K)             &
51     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
52     &  -WA1(I-1)*((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))         &
53     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))+(TI11*(CC(1,I-1,3,K)          &
54     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))         
55        CH(1,I,K,2) = WA1(I-2)*((CC(1,I,1,K)+TR11*(CC(1,I,3,K)          &
56     &  -CC(1,IC,2,K))+TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))                 &
57     &  +(TI11*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))+TI12                      &
58     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))+WA1(I-1)                      &
59     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)                            &
60     &  +CC(1,IC-1,2,K))+TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))           &
61     &  -(TI11*(CC(1,I,3,K)+CC(1,IC,2,K))+TI12                          &
62     &  *(CC(1,I,5,K)+CC(1,IC,4,K))))                                   
63        CH(1,I-1,K,3) = WA2(I-2)                                        &
64     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
65     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI12*(CC(1,I,3,K)        &
66     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
67     & -WA2(I-1)                                                        &
68     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
69     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
70     &  +(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
71     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               
72        CH(1,I,K,3) = WA2(I-2)                                          &
73     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
74     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
75     &  +(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
76     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               &
77     &  +WA2(I-1)                                                       &
78     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
79     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI12*(CC(1,I,3,K)        &
80     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))               
81        CH(1,I-1,K,4) = WA3(I-2)                                        &
82     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
83     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI12*(CC(1,I,3,K)        &
84     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
85     &  -WA3(I-1)                                                       &
86     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
87     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
88     &  -(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
89     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               
90        CH(1,I,K,4) = WA3(I-2)                                          &
91     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
92     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
93     &  -(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
94     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               &
95     &  +WA3(I-1)                                                       &
96     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
97     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI12*(CC(1,I,3,K)        &
98     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))               
99        CH(1,I-1,K,5) = WA4(I-2)                                        &
100     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
101     &  +TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI11*(CC(1,I,3,K)        &
102     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
103     &  -WA4(I-1)                                                       &
104     &  *((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))                  &
105     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))-(TI11*(CC(1,I-1,3,K)          &
106     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))         
107        CH(1,I,K,5) = WA4(I-2)                                          &
108     &  *((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))                  &
109     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))-(TI11*(CC(1,I-1,3,K)          &
110     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))          &
111     &  +WA4(I-1)                                                       &
112     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
113     &  +TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI11*(CC(1,I,3,K)        &
114     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))               
115  102    CONTINUE
116  103 END DO
117      RETURN
118      END                                           
Note: See TracBrowser for help on using the repository browser.