wrfv2_fire/external/fftpack/fftpack5/r1f2kb.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: r1f2kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $
  11 !
  12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13
  14       SUBROUTINE R1F2KB (IDO,L1,CC,IN1,CH,IN2,WA1)
  15       REAL       CC(IN1,IDO,2,L1), CH(IN2,IDO,L1,2), WA1(IDO)
  16 !
  17       DO 101 K=1,L1
  18          CH(1,1,K,1) = CC(1,1,1,K)+CC(1,IDO,2,K)
  19          CH(1,1,K,2) = CC(1,1,1,K)-CC(1,IDO,2,K)
  20   101 END DO
  21       IF (IDO-2) 107,105,102
  22   102 IDP2 = IDO+2
  23       DO 104 K=1,L1
  24          DO 103 I=3,IDO,2
  25             IC = IDP2-I
  26
  27             CH(1,I-1,K,1) = CC(1,I-1,1,K)+CC(1,IC-1,2,K)
  28             CH(1,I,K,1) = CC(1,I,1,K)-CC(1,IC,2,K)
  29
  30             CH(1,I-1,K,2) = WA1(I-2)*(CC(1,I-1,1,K)-CC(1,IC-1,2,K))     &
  31      &           -WA1(I-1)*(CC(1,I,1,K)+CC(1,IC,2,K))
  32             CH(1,I,K,2) = WA1(I-2)*(CC(1,I,1,K)+CC(1,IC,2,K))+WA1(I-1)  &
  33      &           *(CC(1,I-1,1,K)-CC(1,IC-1,2,K))
  34
  35   103    CONTINUE
  36   104 END DO
  37       IF (MOD(IDO,2) .EQ. 1) RETURN
  38   105 DO 106 K=1,L1
  39          CH(1,IDO,K,1) = CC(1,IDO,1,K)+CC(1,IDO,1,K)
  40          CH(1,IDO,K,2) = -(CC(1,1,2,K)+CC(1,1,2,K))
  41   106 END DO
  42   107 RETURN
  43       END