wrfv2_fire/external/fftpack/fftpack5/mrfti1.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: mrfti1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $
  11 !
  12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13
  14       SUBROUTINE MRFTI1 (N,WA,FAC)
  15       REAL       WA(N)      ,FAC(15)
  16       INTEGER    NTRYH(4)
  17       DOUBLE PRECISION TPI,ARGH,ARGLD,ARG
  18       DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
  19 !
  20       NL = N
  21       NF = 0
  22       J = 0
  23   101 J = J+1
  24       IF (J-4) 102,102,103
  25   102 NTRY = NTRYH(J)
  26       GO TO 104
  27   103 NTRY = NTRY+2
  28   104 NQ = NL/NTRY
  29       NR = NL-NTRY*NQ
  30       IF (NR) 101,105,101
  31   105 NF = NF+1
  32       FAC(NF+2) = NTRY
  33       NL = NQ
  34       IF (NTRY .NE. 2) GO TO 107
  35       IF (NF .EQ. 1) GO TO 107
  36       DO 106 I=2,NF
  37          IB = NF-I+2
  38          FAC(IB+2) = FAC(IB+1)
  39   106 END DO
  40       FAC(3) = 2
  41   107 IF (NL .NE. 1) GO TO 104
  42       FAC(1) = N
  43       FAC(2) = NF
  44       TPI = 8.D0*DATAN(1.D0)
  45       ARGH = TPI/FLOAT(N)
  46       IS = 0
  47       NFM1 = NF-1
  48       L1 = 1
  49       IF (NFM1 .EQ. 0) RETURN
  50       DO 110 K1=1,NFM1
  51          IP = FAC(K1+2)
  52          LD = 0
  53          L2 = L1*IP
  54          IDO = N/L2
  55          IPM = IP-1
  56          DO 109 J=1,IPM
  57             LD = LD+L1
  58             I = IS
  59             ARGLD = FLOAT(LD)*ARGH
  60             FI = 0.
  61             DO 108 II=3,IDO,2
  62                I = I+2
  63                FI = FI+1.
  64                ARG = FI*ARGLD
  65                WA(I-1) = DCOS(ARG)
  66                WA(I) = DSIN(ARG)
  67   108       CONTINUE
  68             IS = IS+IDO
  69   109    CONTINUE
  70          L1 = L2
  71   110 END DO
  72       RETURN
  73       END