source: lmdz_wrf/WRFV3/external/fftpack/fftpack5/mcsqf1.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.5 KB
Line 
1!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2!                                                                       
3!   FFTPACK 5.0                                                         
4!                                                                       
5!   Authors:  Paul N. Swarztrauber and Richard A. Valent               
6!                                                                       
7!   $Id: mcsqf1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $               
8!                                                                       
9!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10                                                                       
11      SUBROUTINE MCSQF1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER)
12      DIMENSION       X(INC,*)      ,WSAVE(*)      ,WORK(LOT,*)
13      IER = 0
14      LJ = (LOT-1)*JUMP+1
15      NS2 = (N+1)/2
16      NP2 = N+2
17      DO 101 K=2,NS2
18         KC = NP2-K
19         M1 = 0
20         DO 201 M=1,LJ,JUMP
21         M1 = M1 + 1
22         WORK(M1,K)  = X(M,K)+X(M,KC)
23         WORK(M1,KC) = X(M,K)-X(M,KC)
24  201    CONTINUE
25  101 END DO
26      MODN = MOD(N,2)
27      IF (MODN .NE. 0) GO TO 301
28         M1 = 0
29         DO 202 M=1,LJ,JUMP
30         M1 = M1 + 1
31         WORK(M1,NS2+1) = X(M,NS2+1)+X(M,NS2+1)
32  202    CONTINUE
33  301    DO 102 K=2,NS2
34         KC = NP2-K
35         M1 = 0
36         DO 302 M=1,LJ,JUMP
37         M1 = M1 + 1
38         X(M,K)  = WSAVE(K-1)*WORK(M1,KC)+WSAVE(KC-1)*WORK(M1,K)
39         X(M,KC) = WSAVE(K-1)*WORK(M1,K) -WSAVE(KC-1)*WORK(M1,KC)
40  302    CONTINUE
41  102 END DO
42      IF (MODN .NE. 0) GO TO 303
43      M1 = 0
44      DO 304 M=1,LJ,JUMP
45         M1 = M1 + 1
46         X(M,NS2+1) = WSAVE(NS2)*WORK(M1,NS2+1)
47  304 END DO
48  303 CONTINUE
49      LENX = (LOT-1)*JUMP + INC*(N-1)  + 1
50      LNSV = N + INT(LOG(REAL(N))) + 4
51      LNWK = LOT*N
52!                                                                       
53      CALL RFFTMF(LOT,JUMP,N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1)
54      IF (IER1 .NE. 0) THEN
55        IER = 20
56        CALL XERFFT ('MCSQF1',-5)
57        GO TO 400
58      ENDIF
59!                                                                       
60      DO 103 I=3,N,2
61         DO 203 M=1,LJ,JUMP
62            XIM1 = .5*(X(M,I-1)+X(M,I))
63            X(M,I) = .5*(X(M,I-1)-X(M,I))
64            X(M,I-1) = XIM1
65  203    CONTINUE
66  103 END DO
67  400 CONTINUE
68      RETURN
69      END                                           
Note: See TracBrowser for help on using the repository browser.