!-------------------------------------- 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: mradfg_8.ftn,v 1.4 2011/11/29 15:45:00 armaanl Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
SUBROUTINE MRADFG_8 (M,IDO,IP,L1,IDL1,CC,C1,C2,IM1,IN1, 2
1 CH,CH2,IM2,IN2,WA)
#include "taglam4d.cdk"
REAL*8 CH(IN2,IDO,L1,IP) ,CC(IN1,IDO,IP,L1),
1 C1(IN1,IDO,L1,IP) ,C2(IN1,IDL1,IP),
2 CH2(IN2,IDL1,IP) ,WA(IDO)
!
real*8 TPI,ARG,DCP,DSP
real*8 AR1,AI1,AR1H
real*8 DC2,DS2,AR2,AI2,AR2H
C
M1D = (M-1)*IM1+1
M2S = 1-IM2
TPI = 8.D0*DATAN(1.D0)
ARG = TPI/REAL(IP)
DCP = DCOS(ARG)
DSP = DSIN(ARG)
IPPH = (IP+1)/2
IPP2 = IP+2
IDP2 = IDO+2
NBD = (IDO-1)/2
IF (IDO .EQ. 1) GO TO 119
DO 101 IK=1,IDL1
M2 = M2S
DO 1001 M1=1,M1D,IM1
M2 = M2+IM2
CH2(M2,IK,1) = C2(M1,IK,1)
1001 CONTINUE
101 CONTINUE
DO 103 J=2,IP
DO 102 K=1,L1
M2 = M2S
DO 1002 M1=1,M1D,IM1
M2 = M2+IM2
CH(M2,1,K,J) = C1(M1,1,K,J)
1002 CONTINUE
102 CONTINUE
103 CONTINUE
IF (NBD .GT. L1) GO TO 107
IS = -IDO
DO 106 J=2,IP
IS = IS+IDO
IDIJ = IS
DO 105 I=3,IDO,2
IDIJ = IDIJ+2
DO 104 K=1,L1
M2 = M2S
DO 1004 M1=1,M1D,IM1
M2 = M2+IM2
CH(M2,I-1,K,J) = WA(IDIJ-1)*C1(M1,I-1,K,J)+WA(IDIJ)
1 *C1(M1,I,K,J)
CH(M2,I,K,J) = WA(IDIJ-1)*C1(M1,I,K,J)-WA(IDIJ)
1 *C1(M1,I-1,K,J)
1004 CONTINUE
104 CONTINUE
105 CONTINUE
106 CONTINUE
GO TO 111
107 IS = -IDO
DO 110 J=2,IP
IS = IS+IDO
DO 109 K=1,L1
IDIJ = IS
DO 108 I=3,IDO,2
IDIJ = IDIJ+2
M2 = M2S
DO 1008 M1=1,M1D,IM1
M2 = M2+IM2
CH(M2,I-1,K,J) = WA(IDIJ-1)*C1(M1,I-1,K,J)+WA(IDIJ)
1 *C1(M1,I,K,J)
CH(M2,I,K,J) = WA(IDIJ-1)*C1(M1,I,K,J)-WA(IDIJ)
1 *C1(M1,I-1,K,J)
1008 CONTINUE
108 CONTINUE
109 CONTINUE
110 CONTINUE
111 IF (NBD .LT. L1) GO TO 115
DO 114 J=2,IPPH
JC = IPP2-J
DO 113 K=1,L1
DO 112 I=3,IDO,2
M2 = M2S
DO 1012 M1=1,M1D,IM1
M2 = M2+IM2
C1(M1,I-1,K,J) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC)
C1(M1,I-1,K,JC) = CH(M2,I,K,J)-CH(M2,I,K,JC)
C1(M1,I,K,J) = CH(M2,I,K,J)+CH(M2,I,K,JC)
C1(M1,I,K,JC) = CH(M2,I-1,K,JC)-CH(M2,I-1,K,J)
1012 CONTINUE
112 CONTINUE
113 CONTINUE
114 CONTINUE
GO TO 121
115 DO 118 J=2,IPPH
JC = IPP2-J
DO 117 I=3,IDO,2
DO 116 K=1,L1
M2 = M2S
DO 1016 M1=1,M1D,IM1
M2 = M2+IM2
C1(M1,I-1,K,J) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC)
C1(M1,I-1,K,JC) = CH(M2,I,K,J)-CH(M2,I,K,JC)
C1(M1,I,K,J) = CH(M2,I,K,J)+CH(M2,I,K,JC)
C1(M1,I,K,JC) = CH(M2,I-1,K,JC)-CH(M2,I-1,K,J)
1016 CONTINUE
116 CONTINUE
117 CONTINUE
118 CONTINUE
GO TO 121
119 DO 120 IK=1,IDL1
M2 = M2S
DO 1020 M1=1,M1D,IM1
M2 = M2+IM2
C2(M1,IK,1) = CH2(M2,IK,1)
1020 CONTINUE
120 CONTINUE
121 DO 123 J=2,IPPH
JC = IPP2-J
DO 122 K=1,L1
M2 = M2S
DO 1022 M1=1,M1D,IM1
M2 = M2+IM2
C1(M1,1,K,J) = CH(M2,1,K,J)+CH(M2,1,K,JC)
C1(M1,1,K,JC) = CH(M2,1,K,JC)-CH(M2,1,K,J)
1022 CONTINUE
122 CONTINUE
123 CONTINUE
C
AR1 = 1.d0
AI1 = 0.d0
DO 127 L=2,IPPH
LC = IPP2-L
AR1H = DCP*AR1-DSP*AI1
AI1 = DCP*AI1+DSP*AR1
AR1 = AR1H
DO 124 IK=1,IDL1
M2 = M2S
DO 1024 M1=1,M1D,IM1
M2 = M2+IM2
CH2(M2,IK,L) = C2(M1,IK,1)+AR1*C2(M1,IK,2)
CH2(M2,IK,LC) = AI1*C2(M1,IK,IP)
1024 CONTINUE
124 CONTINUE
DC2 = AR1
DS2 = AI1
AR2 = AR1
AI2 = AI1
DO 126 J=3,IPPH
JC = IPP2-J
AR2H = DC2*AR2-DS2*AI2
AI2 = DC2*AI2+DS2*AR2
AR2 = AR2H
DO 125 IK=1,IDL1
M2 = M2S
DO 1025 M1=1,M1D,IM1
M2 = M2+IM2
CH2(M2,IK,L) = CH2(M2,IK,L)+AR2*C2(M1,IK,J)
CH2(M2,IK,LC) = CH2(M2,IK,LC)+AI2*C2(M1,IK,JC)
1025 CONTINUE
125 CONTINUE
126 CONTINUE
127 CONTINUE
DO 129 J=2,IPPH
DO 128 IK=1,IDL1
M2 = M2S
DO 1028 M1=1,M1D,IM1
M2 = M2+IM2
CH2(M2,IK,1) = CH2(M2,IK,1)+C2(M1,IK,J)
1028 CONTINUE
128 CONTINUE
129 CONTINUE
C
IF (IDO .LT. L1) GO TO 132
DO 131 K=1,L1
DO 130 I=1,IDO
M2 = M2S
DO 1030 M1=1,M1D,IM1
M2 = M2+IM2
CC(M1,I,1,K) = CH(M2,I,K,1)
1030 CONTINUE
130 CONTINUE
131 CONTINUE
GO TO 135
132 DO 134 I=1,IDO
DO 133 K=1,L1
M2 = M2S
DO 1033 M1=1,M1D,IM1
M2 = M2+IM2
CC(M1,I,1,K) = CH(M2,I,K,1)
1033 CONTINUE
133 CONTINUE
134 CONTINUE
135 DO 137 J=2,IPPH
JC = IPP2-J
J2 = J+J
DO 136 K=1,L1
M2 = M2S
DO 1036 M1=1,M1D,IM1
M2 = M2+IM2
CC(M1,IDO,J2-2,K) = CH(M2,1,K,J)
CC(M1,1,J2-1,K) = CH(M2,1,K,JC)
1036 CONTINUE
136 CONTINUE
137 CONTINUE
IF (IDO .EQ. 1) RETURN
IF (NBD .LT. L1) GO TO 141
DO 140 J=2,IPPH
JC = IPP2-J
J2 = J+J
DO 139 K=1,L1
DO 138 I=3,IDO,2
IC = IDP2-I
M2 = M2S
DO 1038 M1=1,M1D,IM1
M2 = M2+IM2
CC(M1,I-1,J2-1,K) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC)
CC(M1,IC-1,J2-2,K) = CH(M2,I-1,K,J)-CH(M2,I-1,K,JC)
CC(M1,I,J2-1,K) = CH(M2,I,K,J)+CH(M2,I,K,JC)
CC(M1,IC,J2-2,K) = CH(M2,I,K,JC)-CH(M2,I,K,J)
1038 CONTINUE
138 CONTINUE
139 CONTINUE
140 CONTINUE
RETURN
141 DO 144 J=2,IPPH
JC = IPP2-J
J2 = J+J
DO 143 I=3,IDO,2
IC = IDP2-I
DO 142 K=1,L1
M2 = M2S
DO 1042 M1=1,M1D,IM1
M2 = M2+IM2
CC(M1,I-1,J2-1,K) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC)
CC(M1,IC-1,J2-2,K) = CH(M2,I-1,K,J)-CH(M2,I-1,K,JC)
CC(M1,I,J2-1,K) = CH(M2,I,K,J)+CH(M2,I,K,JC)
CC(M1,IC,J2-2,K) = CH(M2,I,K,JC)-CH(M2,I,K,J)
1042 CONTINUE
142 CONTINUE
143 CONTINUE
144 CONTINUE
RETURN
END