source: lmdz_wrf/WRFV3/external/fftpack/fftpack5/costb1.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: 2.6 KB
Line 
1!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2!                                                                       
3!   FFTPACK 5.0                                                         
4!                                                                       
5!   Authors:  Paul N. Swarztrauber and Richard A. Valent               
6!                                                                       
7!   $Id: costb1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $               
8!                                                                       
9!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10                                                                       
11      SUBROUTINE COSTB1(N,INC,X,WSAVE,WORK,IER)
12      REAL       X(INC,*)       ,WSAVE(*)
13      DOUBLE PRECISION           DSUM
14      IER = 0
15      NM1 = N-1
16      NP1 = N+1
17      NS2 = N/2
18      IF (N-2) 106,101,102
19  101 X1H = X(1,1)+X(1,2)
20      X(1,2) = X(1,1)-X(1,2)
21      X(1,1) = X1H
22      RETURN
23  102 IF (N .GT. 3) GO TO 103
24      X1P3 = X(1,1)+X(1,3)
25      X2 = X(1,2)
26      X(1,2) = X(1,1)-X(1,3)
27      X(1,1) = X1P3+X2
28      X(1,3) = X1P3-X2
29      RETURN
30  103 X(1,1) = X(1,1)+X(1,1)
31      X(1,N) = X(1,N)+X(1,N)
32      DSUM = X(1,1)-X(1,N)
33      X(1,1) = X(1,1)+X(1,N)
34      DO 104 K=2,NS2
35         KC = NP1-K
36         T1 = X(1,K)+X(1,KC)
37         T2 = X(1,K)-X(1,KC)
38         DSUM = DSUM+WSAVE(KC)*T2
39         T2 = WSAVE(K)*T2
40         X(1,K) = T1-T2
41         X(1,KC) = T1+T2
42  104 END DO
43      MODN = MOD(N,2)
44      IF (MODN .EQ. 0) GO TO 124
45      X(1,NS2+1) = X(1,NS2+1)+X(1,NS2+1)
46  124 LENX = INC*(NM1-1)  + 1
47      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4
48      LNWK = NM1
49!                                                                       
50      CALL RFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,                  &
51     &            LNWK,IER1)                                           
52      IF (IER1 .NE. 0) THEN
53        IER = 20
54        CALL XERFFT ('COSTB1',-5)
55        RETURN
56      ENDIF
57!                                                                       
58      FNM1S2 = FLOAT(NM1)/2.
59      DSUM = .5*DSUM
60      X(1,1) = FNM1S2*X(1,1)
61      IF(MOD(NM1,2) .NE. 0) GO TO 30
62      X(1,NM1) = X(1,NM1)+X(1,NM1)
63   30 FNM1S4 = FLOAT(NM1)/4.
64      DO 105 I=3,N,2
65         XI = FNM1S4*X(1,I)
66         X(1,I) = FNM1S4*X(1,I-1)
67         X(1,I-1) = DSUM
68         DSUM = DSUM+XI
69  105 END DO
70      IF (MODN .NE. 0) RETURN
71         X(1,N) = DSUM
72  106 RETURN
73      END                                           
Note: See TracBrowser for help on using the repository browser.