source: trunk/WRF.COMMON/WRFV3/external/fftpack/fftpack5/mradb4.F

Last change on this file was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 4.7 KB
Line 
1!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2!                                                                       
3!   FFTPACK 5.0                                                         
4!   Copyright (C) 1995-2004, Scientific Computing Division,             
5!   University Corporation for Atmospheric Research                     
6!   Licensed under the GNU General Public License (GPL)                 
7!                                                                       
8!   Authors:  Paul N. Swarztrauber and Richard A. Valent               
9!                                                                       
10!   $Id: mradb4.f,v 1.2 2004/06/15 21:29:19 rodney Exp $               
11!                                                                       
12!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
13                                                                       
14      SUBROUTINE MRADB4 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2,WA3)
15      REAL       CC(IN1,IDO,4,L1)  ,CH(IN2,IDO,L1,4)    ,               &
16     &           WA1(IDO)  ,        WA2(IDO)  ,       WA3(IDO)         
17!                                                                       
18      M1D = (M-1)*IM1+1
19      M2S = 1-IM2
20      SQRT2=SQRT(2.)
21      DO 101 K=1,L1
22          M2 = M2S
23          DO 1001 M1=1,M1D,IM1
24          M2 = M2+IM2
25         CH(M2,1,K,3) = (CC(M1,1,1,K)+CC(M1,IDO,4,K))                   &
26     &   -(CC(M1,IDO,2,K)+CC(M1,IDO,2,K))                               
27         CH(M2,1,K,1) = (CC(M1,1,1,K)+CC(M1,IDO,4,K))                   &
28     &   +(CC(M1,IDO,2,K)+CC(M1,IDO,2,K))                               
29         CH(M2,1,K,4) = (CC(M1,1,1,K)-CC(M1,IDO,4,K))                   &
30     &   +(CC(M1,1,3,K)+CC(M1,1,3,K))                                   
31         CH(M2,1,K,2) = (CC(M1,1,1,K)-CC(M1,IDO,4,K))                   &
32     &   -(CC(M1,1,3,K)+CC(M1,1,3,K))                                   
33 1001     CONTINUE
34  101 END DO
35      IF (IDO-2) 107,105,102
36  102 IDP2 = IDO+2
37      DO 104 K=1,L1
38         DO 103 I=3,IDO,2
39            IC = IDP2-I
40               M2 = M2S
41               DO 1002 M1=1,M1D,IM1
42               M2 = M2+IM2
43        CH(M2,I-1,K,1) = (CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))               &
44     &  +(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))                               
45        CH(M2,I,K,1) = (CC(M1,I,1,K)-CC(M1,IC,4,K))                     &
46     &  +(CC(M1,I,3,K)-CC(M1,IC,2,K))                                   
47        CH(M2,I-1,K,2)=WA1(I-2)*((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))       &
48     &  -(CC(M1,I,3,K)+CC(M1,IC,2,K)))-WA1(I-1)                         &
49     &  *((CC(M1,I,1,K)+CC(M1,IC,4,K))+(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))
50        CH(M2,I,K,2)=WA1(I-2)*((CC(M1,I,1,K)+CC(M1,IC,4,K))             &
51     &  +(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))+WA1(I-1)                     &
52     &  *((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))-(CC(M1,I,3,K)+CC(M1,IC,2,K)))
53        CH(M2,I-1,K,3)=WA2(I-2)*((CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))       &
54     &  -(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-WA2(I-1)                     &
55     &  *((CC(M1,I,1,K)-CC(M1,IC,4,K))-(CC(M1,I,3,K)-CC(M1,IC,2,K)))   
56        CH(M2,I,K,3)=WA2(I-2)*((CC(M1,I,1,K)-CC(M1,IC,4,K))             &
57     &  -(CC(M1,I,3,K)-CC(M1,IC,2,K)))+WA2(I-1)                         &
58     &  *((CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))-(CC(M1,I-1,3,K)              &
59     &  +CC(M1,IC-1,2,K)))                                             
60        CH(M2,I-1,K,4)=WA3(I-2)*((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))       &
61     &  +(CC(M1,I,3,K)+CC(M1,IC,2,K)))-WA3(I-1)                         &
62     & *((CC(M1,I,1,K)+CC(M1,IC,4,K))-(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))
63        CH(M2,I,K,4)=WA3(I-2)*((CC(M1,I,1,K)+CC(M1,IC,4,K))             &
64     &  -(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))+WA3(I-1)                     &
65     &  *((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))+(CC(M1,I,3,K)+CC(M1,IC,2,K)))
66 1002          CONTINUE
67  103    CONTINUE
68  104 END DO
69      IF (MOD(IDO,2) .EQ. 1) RETURN
70  105 CONTINUE
71      DO 106 K=1,L1
72               M2 = M2S
73               DO 1003 M1=1,M1D,IM1
74               M2 = M2+IM2
75         CH(M2,IDO,K,1) = (CC(M1,IDO,1,K)+CC(M1,IDO,3,K))               &
76     &   +(CC(M1,IDO,1,K)+CC(M1,IDO,3,K))                               
77         CH(M2,IDO,K,2) = SQRT2*((CC(M1,IDO,1,K)-CC(M1,IDO,3,K))        &
78     &   -(CC(M1,1,2,K)+CC(M1,1,4,K)))                                 
79         CH(M2,IDO,K,3) = (CC(M1,1,4,K)-CC(M1,1,2,K))                   &
80     &   +(CC(M1,1,4,K)-CC(M1,1,2,K))                                   
81         CH(M2,IDO,K,4) = -SQRT2*((CC(M1,IDO,1,K)-CC(M1,IDO,3,K))       &
82     &   +(CC(M1,1,2,K)+CC(M1,1,4,K)))                                 
83 1003          CONTINUE
84  106 END DO
85  107 RETURN
86      END                                           
Note: See TracBrowser for help on using the repository browser.