wrfv2_fire/external/fftpack/fftpack5/mrftf1.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: mrftf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $
  11 !
  12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13
  14       SUBROUTINE MRFTF1 (M,IM,N,IN,C,CH,WA,FAC)
  15       REAL       CH(M,*) ,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 MRADF4 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),WA(IX3))
  34          GO TO 110
  35   101    CALL MRADF4 (M,IDO,L1,CH,1,M,C,IM,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 MRADF2 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW))
  40          GO TO 110
  41   103    CALL MRADF2 (M,IDO,L1,CH,1,M,C,IM,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 MRADF3 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2))
  47          GO TO 110
  48   105    CALL MRADF3 (M,IDO,L1,CH,1,M,C,IM,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 MRADF5(M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),            &
  56      &                      WA(IX3),WA(IX4))
  57          GO TO 110
  58   107    CALL MRADF5(M,IDO,L1,CH,1,M,C,IM,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 MRADFG (M,IDO,IP,L1,IDL1,C,C,C,IM,IN,CH,CH,1,M,WA(IW))
  64          NA = 1
  65          GO TO 110
  66   109    CALL MRADFG (M,IDO,IP,L1,IDL1,CH,CH,CH,1,M,C,C,IM,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       M2 = 1-IM
  78       DO 117 I=1,M
  79          M2 = M2+IM
  80          C(M2,1) = SN*CH(I,1)
  81   117 END DO
  82       DO 118 J=2,NL,2
  83       M2 = 1-IM
  84       DO 118 I=1,M
  85          M2 = M2+IM
  86          C(M2,J) = TSN*CH(I,J)
  87          C(M2,J+1) = TSNM*CH(I,J+1)
  88   118 CONTINUE
  89       IF(MODN .NE. 0) RETURN
  90       M2 = 1-IM
  91       DO 119 I=1,M
  92          M2 = M2+IM
  93          C(M2,N) = SN*CH(I,N)
  94   119 END DO
  95       RETURN
  96   120 M2 = 1-IM
  97       DO 121 I=1,M
  98          M2 = M2+IM
  99          C(M2,1) = SN*C(M2,1)
 100   121 END DO
 101       DO 122 J=2,NL,2
 102       M2 = 1-IM
 103       DO 122 I=1,M
 104          M2 = M2+IM
 105          C(M2,J) = TSN*C(M2,J)
 106          C(M2,J+1) = TSNM*C(M2,J+1)
 107   122 CONTINUE
 108       IF(MODN .NE. 0) RETURN
 109       M2 = 1-IM
 110       DO 123 I=1,M
 111          M2 = M2+IM
 112          C(M2,N) = SN*C(M2,N)
 113   123 END DO
 114       RETURN
 115       END