wrfv2_fire/external/fftpack/fftpack5/mradb3.F

   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: mradb3.f,v 1.2 2004/06/15 21:29:19 rodney Exp $
  11 !
  12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13
  14       SUBROUTINE MRADB3 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2)
  15       REAL       CC(IN1,IDO,3,L1)    ,CH(IN2,IDO,L1,3),                 &
  16      &           WA1(IDO)   ,WA2(IDO)
  17 !
  18       M1D = (M-1)*IM1+1
  19       M2S = 1-IM2
  20       ARG=2.*4.*ATAN(1.0)/3.
  21       TAUR=COS(ARG)
  22       TAUI=SIN(ARG)
  23       DO 101 K=1,L1
  24           M2 = M2S
  25           DO 1001 M1=1,M1D,IM1
  26           M2 = M2+IM2
  27          CH(M2,1,K,1) = CC(M1,1,1,K)+2.*CC(M1,IDO,2,K)
  28          CH(M2,1,K,2) = CC(M1,1,1,K)+(2.*TAUR)*CC(M1,IDO,2,K)           &
  29      &   -(2.*TAUI)*CC(M1,1,3,K)
  30          CH(M2,1,K,3) = CC(M1,1,1,K)+(2.*TAUR)*CC(M1,IDO,2,K)           &
  31      &   +2.*TAUI*CC(M1,1,3,K)
  32  1001     CONTINUE
  33   101 END DO
  34       IF (IDO .EQ. 1) RETURN
  35       IDP2 = IDO+2
  36       DO 103 K=1,L1
  37          DO 102 I=3,IDO,2
  38             IC = IDP2-I
  39                M2 = M2S
  40                DO 1002 M1=1,M1D,IM1
  41                M2 = M2+IM2
  42         CH(M2,I-1,K,1) = CC(M1,I-1,1,K)+(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))
  43         CH(M2,I,K,1) = CC(M1,I,1,K)+(CC(M1,I,3,K)-CC(M1,IC,2,K))
  44         CH(M2,I-1,K,2) = WA1(I-2)*                                      &
  45      & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-         &
  46      & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             &
  47      &                   -WA1(I-1)*                                     &
  48      & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))+               &
  49      & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))
  50             CH(M2,I,K,2) = WA1(I-2)*                                    &
  51      & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))+               &
  52      & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         &
  53      &                  +WA1(I-1)*                                      &
  54      & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-         &
  55      & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))
  56               CH(M2,I-1,K,3) = WA2(I-2)*                                &
  57      & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))+         &
  58      & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             &
  59      &   -WA2(I-1)*                                                     &
  60      & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))-               &
  61      & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))
  62             CH(M2,I,K,3) = WA2(I-2)*                                    &
  63      & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))-               &
  64      & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         &
  65      &                 +WA2(I-1)*                                       &
  66      & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))+         &
  67      & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))
  68  1002          CONTINUE
  69   102    CONTINUE
  70   103 END DO
  71       RETURN
  72       END