wrfv2_fire/external/fftpack/fftpack5/rfftf1.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: rfftf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $
  11 !
  12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13
  14       SUBROUTINE RFFTF1 (N,IN,C,CH,WA,FAC)
  15       REAL       CH(*) ,C(IN,*)  ,WA(N)   ,FAC(15)
  16 !
  17       NF = FAC(2)
  18       NA = 1
  19       L2 = N
  20       IW = N
  21       DO 111 K1=1,NF
  22          KH = NF-K1
  23          IP = FAC(KH+3)
  24          L1 = L2/IP
  25          IDO = N/L2
  26          IDL1 = IDO*L1
  27          IW = IW-(IP-1)*IDO
  28          NA = 1-NA
  29          IF (IP .NE. 4) GO TO 102
  30          IX2 = IW+IDO
  31          IX3 = IX2+IDO
  32          IF (NA .NE. 0) GO TO 101
  33          CALL R1F4KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3))
  34          GO TO 110
  35   101    CALL R1F4KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3))
  36          GO TO 110
  37   102    IF (IP .NE. 2) GO TO 104
  38          IF (NA .NE. 0) GO TO 103
  39          CALL R1F2KF (IDO,L1,C,IN,CH,1,WA(IW))
  40          GO TO 110
  41   103    CALL R1F2KF (IDO,L1,CH,1,C,IN,WA(IW))
  42          GO TO 110
  43   104    IF (IP .NE. 3) GO TO 106
  44          IX2 = IW+IDO
  45          IF (NA .NE. 0) GO TO 105
  46          CALL R1F3KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))
  47          GO TO 110
  48   105    CALL R1F3KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2))
  49          GO TO 110
  50   106    IF (IP .NE. 5) GO TO 108
  51          IX2 = IW+IDO
  52          IX3 = IX2+IDO
  53          IX4 = IX3+IDO
  54          IF (NA .NE. 0) GO TO 107
  55          CALL R1F5KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),                  &
  56      &                      WA(IX3),WA(IX4))
  57          GO TO 110
  58   107    CALL R1F5KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),                  &
  59      &                      WA(IX3),WA(IX4))
  60          GO TO 110
  61   108    IF (IDO .EQ. 1) NA = 1-NA
  62          IF (NA .NE. 0) GO TO 109
  63          CALL R1FGKF (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))
  64          NA = 1
  65          GO TO 110
  66   109    CALL R1FGKF (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))
  67          NA = 0
  68   110    L2 = L1
  69   111 END DO
  70       SN = 1./N
  71       TSN = 2./N
  72       TSNM = -TSN
  73       MODN = MOD(N,2)
  74       NL = N-2
  75       IF(MODN .NE. 0) NL = N-1
  76       IF (NA .NE. 0) GO TO 120
  77       C(1,1) = SN*CH(1)
  78       DO 118 J=2,NL,2
  79          C(1,J) = TSN*CH(J)
  80          C(1,J+1) = TSNM*CH(J+1)
  81   118 END DO
  82       IF(MODN .NE. 0) RETURN
  83       C(1,N) = SN*CH(N)
  84       RETURN
  85   120 C(1,1) = SN*C(1,1)
  86       DO 122 J=2,NL,2
  87          C(1,J) = TSN*C(1,J)
  88          C(1,J+1) = TSNM*C(1,J+1)
  89   122 END DO
  90       IF(MODN .NE. 0) RETURN
  91       C(1,N) = SN*C(1,N)
  92       RETURN
  93       END