source: lmdz_wrf/trunk/WRFV3/external/fftpack/fftpack5/msntf1.F @ 565

Last change on this file since 565 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: 2.9 KB
Line 
1!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2!                                                                       
3!   FFTPACK 5.0                                                         
4!                                                                       
5!   Authors:  Paul N. Swarztrauber and Richard A. Valent               
6!                                                                       
7!   $Id: msntf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $               
8!                                                                       
9!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10                                                                       
11      SUBROUTINE MSNTF1(LOT,JUMP,N,INC,X,WSAVE,DSUM,XH,WORK,IER)
12      REAL       X(INC,*)       ,WSAVE(*)   ,XH(LOT,*)
13      DOUBLE PRECISION           DSUM(*)
14      IER = 0
15      LJ = (LOT-1)*JUMP+1
16      IF (N-2) 101,102,103
17  102 SSQRT3 = 1./SQRT(3.)
18      DO 112 M=1,LJ,JUMP
19         XHOLD = SSQRT3*(X(M,1)+X(M,2))
20         X(M,2) = SSQRT3*(X(M,1)-X(M,2))
21         X(M,1) = XHOLD
22  112 END DO
23  101  GO TO 200
24  103 NP1 = N+1
25      NS2 = N/2
26      DO 104 K=1,NS2
27         KC = NP1-K
28         M1 = 0
29         DO 114 M=1,LJ,JUMP
30         M1 = M1 + 1
31         T1 = X(M,K)-X(M,KC)
32         T2 = WSAVE(K)*(X(M,K)+X(M,KC))
33         XH(M1,K+1) = T1+T2
34         XH(M1,KC+1) = T2-T1
35  114    CONTINUE
36  104 END DO
37      MODN = MOD(N,2)
38      IF (MODN .EQ. 0) GO TO 124
39      M1 = 0
40      DO 123 M=1,LJ,JUMP
41         M1 = M1 + 1
42         XH(M1,NS2+2) = 4.*X(M,NS2+1)
43  123 END DO
44  124 DO 127 M=1,LOT
45         XH(M,1) = 0.
46  127 END DO
47      LNXH = LOT-1 + LOT*(NP1-1) + 1
48      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4
49      LNWK = LOT*NP1
50!                                                                       
51      CALL RFFTMF(LOT,1,NP1,LOT,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,         &
52     &            LNWK,IER1)                                           
53      IF (IER1 .NE. 0) THEN
54        IER = 20
55        CALL XERFFT ('MSNTF1',-5)
56        GO TO 200
57      ENDIF
58!                                                                       
59      IF(MOD(NP1,2) .NE. 0) GO TO 30
60      DO 20 M=1,LOT
61      XH(M,NP1) = XH(M,NP1)+XH(M,NP1)
62   20 END DO
63   30 SFNP1 = 1./FLOAT(NP1)
64      M1 = 0
65      DO 125 M=1,LJ,JUMP
66         M1 = M1+1
67         X(M,1) = .5*XH(M1,1)
68         DSUM(M1) = X(M,1)
69  125 END DO
70      DO 105 I=3,N,2
71         M1 = 0
72         DO 115 M=1,LJ,JUMP
73            M1 = M1+1
74            X(M,I-1) = .5*XH(M1,I)
75            DSUM(M1) = DSUM(M1)+.5*XH(M1,I-1)
76            X(M,I) = DSUM(M1)
77  115    CONTINUE
78  105 END DO
79      IF (MODN .NE. 0) GO TO 200
80      M1 = 0
81      DO 116 M=1,LJ,JUMP
82         M1 = M1+1
83         X(M,N) = .5*XH(M1,N+1)
84  116 END DO
85  200 CONTINUE
86      RETURN
87      END                                           
Note: See TracBrowser for help on using the repository browser.