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

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

WRF: version v3.3
LMDZ: version v1818

More details in:

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