!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C FFTPACK 5.0
C Copyright (C) 1995-2004, Scientific Computing Division,
C University Corporation for Atmospheric Research
C Licensed under the GNU General Public License (GPL)
C
C Authors: Paul N. Swarztrauber and Richard A. Valent
C
C $Id: mrftf1_8.ftn,v 1.2 2010/08/20 16:39:43 armaanl Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
SUBROUTINE MRFTF1_8 (M,IM,N,IN,C,CH,WA,FAC,klenwrk) 1,10
#include "taglam4d.cdk"
integer klenwrk
REAL*8 CH(M,klenwrk) ,C(IN,M) ,WA(N) ,FAC(15)
! REAL*8 CH(M,*) ,C(IN,*) ,WA(N) ,FAC(15)
real*8 SN,TSN,TSNM
C
! print *,'MRFTF1_8: ACTIVE'
! print *,'MRFTF1_8: FAC=',FAC
! print *,'MRFTF1_8: debut: C = ',C
!
NF = FAC(2)
NA = 1
L2 = N
IW = N
! print *,'mrftf1_8: NF,NA,L2,IW=',NF,NA,L2,IW
DO 111 K1=1,NF
KH = NF-K1
IP = FAC(KH+3)
L1 = L2/IP
IDO = N/L2
IDL1 = IDO*L1
IW = IW-(IP-1)*IDO
NA = 1-NA
IF (IP .NE. 4) GO TO 102
IX2 = IW+IDO
IX3 = IX2+IDO
IF (NA .NE. 0) GO TO 101
! print *,'MRFTF1_8: KH,IP,L1,IDO,IDL1,IW,NA,IX2,IX3=',
! & KH,IP,L1,IDO,IDL1,IW,NA,IX2,IX3
CALL MRADF4_8 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),WA(IX3))
GO TO 110
101 CALL MRADF4_8 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),WA(IX3))
GO TO 110
! 102 continue
102 IF (IP .NE. 2) GO TO 104
IF (NA .NE. 0) GO TO 103
CALL MRADF2_8 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW))
GO TO 110
103 CALL MRADF2_8 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW))
GO TO 110
! 104 continue
104 IF (IP .NE. 3) GO TO 106
IX2 = IW+IDO
IF (NA .NE. 0) GO TO 105
CALL MRADF3_8 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2))
GO TO 110
105 CALL MRADF3_8 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2))
GO TO 110
! 106 continue
106 IF (IP .NE. 5) GO TO 108
IX2 = IW+IDO
IX3 = IX2+IDO
IX4 = IX3+IDO
IF (NA .NE. 0) GO TO 107
CALL MRADF5_8(M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),
1 WA(IX3),WA(IX4))
GO TO 110
107 CALL MRADF5_8(M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),
1 WA(IX3),WA(IX4))
GO TO 110
108 IF (IDO .EQ. 1) NA = 1-NA
IF (NA .NE. 0) GO TO 109
CALL MRADFG_8 (M,IDO,IP,L1,IDL1,C,C,C,IM,IN,CH,CH,1,M,WA(IW))
NA = 1
GO TO 110
109 CALL MRADFG_8 (M,IDO,IP,L1,IDL1,CH,CH,CH,1,M,C,C,IM,IN,WA(IW))
NA = 0
110 L2 = L1
111 CONTINUE
SN = 1.d0/real(N)
TSN = 2.d0/real(N)
TSNM = -TSN
MODN = MOD(N,2)
NL = N-2
IF(MODN .NE. 0) NL = N-1
IF (NA .NE. 0) GO TO 120
M2 = 1-IM
DO 117 I=1,M
M2 = M2+IM
C(M2,1) = SN*CH(I,1)
117 CONTINUE
DO 118 J=2,NL,2
M2 = 1-IM
DO 118 I=1,M
M2 = M2+IM
C(M2,J) = TSN*CH(I,J)
C(M2,J+1) = TSNM*CH(I,J+1)
118 CONTINUE
IF(MODN .NE. 0) RETURN
M2 = 1-IM
DO 119 I=1,M
M2 = M2+IM
C(M2,N) = SN*CH(I,N)
119 CONTINUE
RETURN
120 M2 = 1-IM
DO 121 I=1,M
M2 = M2+IM
C(M2,1) = SN*C(M2,1)
121 CONTINUE
DO 122 J=2,NL,2
M2 = 1-IM
DO 122 I=1,M
M2 = M2+IM
C(M2,J) = TSN*C(M2,J)
C(M2,J+1) = TSNM*C(M2,J+1)
122 CONTINUE
IF(MODN .NE. 0) RETURN
M2 = 1-IM
DO 123 I=1,M
M2 = M2+IM
C(M2,N) = SN*C(M2,N)
123 CONTINUE
RETURN
END