source: lmdz_wrf/WRFV3/external/fftpack/fftpack5/rfftb1.F @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 3.4 KB
Line 
1!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2!                                                                       
3!   FFTPACK 5.0                                                         
4!                                                                       
5!   Authors:  Paul N. Swarztrauber and Richard A. Valent               
6!                                                                       
7!   $Id: rfftb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $               
8!                                                                       
9!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10                                                                       
11      SUBROUTINE RFFTB1 (N,IN,C,CH,WA,FAC)
12      REAL       CH(*), C(IN,*), WA(N) ,FAC(15)
13!                                                                       
14      NF = FAC(2)
15      NA = 0
16      DO 10 K1=1,NF
17      IP = FAC(K1+2)
18      NA = 1-NA
19      IF(IP .LE. 5) GO TO 10
20      IF(K1 .EQ. NF) GO TO 10
21      NA = 1-NA
22   10 END DO
23      HALF = .5
24      HALFM = -.5
25      MODN = MOD(N,2)
26      NL = N-2
27      IF(MODN .NE. 0) NL = N-1
28      IF (NA .EQ. 0) GO TO 120
29      CH(1) = C(1,1)
30      CH(N) = C(1,N)
31      DO 118 J=2,NL,2
32         CH(J) = HALF*C(1,J)
33         CH(J+1) = HALFM*C(1,J+1)
34  118 END DO
35      GO TO 124
36  120 DO 122 J=2,NL,2
37         C(1,J) = HALF*C(1,J)
38         C(1,J+1) = HALFM*C(1,J+1)
39  122 END DO
40  124 L1 = 1
41      IW = 1
42      DO 116 K1=1,NF
43         IP = FAC(K1+2)
44         L2 = IP*L1
45         IDO = N/L2
46         IDL1 = IDO*L1
47         IF (IP .NE. 4) GO TO 103
48         IX2 = IW+IDO
49         IX3 = IX2+IDO
50         IF (NA .NE. 0) GO TO 101
51         CALL R1F4KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3))
52         GO TO 102
53  101    CALL R1F4KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3))
54  102    NA = 1-NA
55         GO TO 115
56  103    IF (IP .NE. 2) GO TO 106
57         IF (NA .NE. 0) GO TO 104
58         CALL R1F2KB (IDO,L1,C,IN,CH,1,WA(IW))
59         GO TO 105
60  104    CALL R1F2KB (IDO,L1,CH,1,C,IN,WA(IW))
61  105    NA = 1-NA
62         GO TO 115
63  106    IF (IP .NE. 3) GO TO 109
64         IX2 = IW+IDO
65         IF (NA .NE. 0) GO TO 107
66! rav    CALL RIF3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))                 
67         CALL R1F3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))
68         GO TO 108
69  107    CALL R1F3KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2))
70  108    NA = 1-NA
71         GO TO 115
72  109    IF (IP .NE. 5) GO TO 112
73         IX2 = IW+IDO
74         IX3 = IX2+IDO
75         IX4 = IX3+IDO
76         IF (NA .NE. 0) GO TO 110
77         CALL R1F5KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),                  &
78     &                  WA(IX3),WA(IX4))                               
79         GO TO 111
80  110    CALL R1F5KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),                  &
81     &                  WA(IX3),WA(IX4))                               
82  111    NA = 1-NA
83         GO TO 115
84  112    IF (NA .NE. 0) GO TO 113
85! rav    CALL RIFGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))           
86         CALL R1FGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))
87         GO TO 114
88! rav 113    CALL RIFGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))     
89  113    CALL R1FGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))
90  114    IF (IDO .EQ. 1) NA = 1-NA
91  115    L1 = L2
92         IW = IW+(IP-1)*IDO
93  116 END DO
94      RETURN
95      END                                           
Note: See TracBrowser for help on using the repository browser.