!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! ! FFTPACK 5.0 ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! Licensed under the GNU General Public License (GPL) ! ! Authors: Paul N. Swarztrauber and Richard A. Valent ! ! $Id: cmfgkf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $ ! !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE CMFGKF (LOT,IDO,IP,L1,LID,NA,CC,CC1,IM1,IN1, & & CH,CH1,IM2,IN2,WA) REAL CH(2,IN2,L1,IDO,IP) ,CC(2,IN1,L1,IP,IDO), & & CC1(2,IN1,LID,IP) ,CH1(2,IN2,LID,IP) , & & WA(IDO,IP-1,2) ! ! FFTPACK 5.0 auxiliary routine ! M1D = (LOT-1)*IM1+1 M2S = 1-IM2 IPP2 = IP+2 IPPH = (IP+1)/2 DO 110 KI=1,LID M2 = M2S DO 110 M1=1,M1D,IM1 M2 = M2+IM2 CH1(1,M2,KI,1) = CC1(1,M1,KI,1) CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 110 CONTINUE DO 111 J=2,IPPH JC = IPP2-J DO 112 KI=1,LID M2 = M2S DO 112 M1=1,M1D,IM1 M2 = M2+IM2 CH1(1,M2,KI,J) = CC1(1,M1,KI,J)+CC1(1,M1,KI,JC) CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)-CC1(1,M1,KI,JC) CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(2,M1,KI,JC) CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(2,M1,KI,JC) 112 CONTINUE 111 END DO DO 118 J=2,IPPH DO 117 KI=1,LID M2 = M2S DO 117 M1=1,M1D,IM1 M2 = M2+IM2 CC1(1,M1,KI,1) = CC1(1,M1,KI,1)+CH1(1,M2,KI,J) CC1(2,M1,KI,1) = CC1(2,M1,KI,1)+CH1(2,M2,KI,J) 117 CONTINUE 118 END DO DO 116 L=2,IPPH LC = IPP2-L DO 113 KI=1,LID M2 = M2S DO 113 M1=1,M1D,IM1 M2 = M2+IM2 CC1(1,M1,KI,L) = CH1(1,M2,KI,1)+WA(1,L-1,1)*CH1(1,M2,KI,2) CC1(1,M1,KI,LC) = -WA(1,L-1,2)*CH1(1,M2,KI,IP) CC1(2,M1,KI,L) = CH1(2,M2,KI,1)+WA(1,L-1,1)*CH1(2,M2,KI,2) CC1(2,M1,KI,LC) = -WA(1,L-1,2)*CH1(2,M2,KI,IP) 113 CONTINUE DO 115 J=3,IPPH JC = IPP2-J IDLJ = MOD((L-1)*(J-1),IP) WAR = WA(1,IDLJ,1) WAI = -WA(1,IDLJ,2) DO 114 KI=1,LID M2 = M2S DO 114 M1=1,M1D,IM1 M2 = M2+IM2 CC1(1,M1,KI,L) = CC1(1,M1,KI,L)+WAR*CH1(1,M2,KI,J) CC1(1,M1,KI,LC) = CC1(1,M1,KI,LC)+WAI*CH1(1,M2,KI,JC) CC1(2,M1,KI,L) = CC1(2,M1,KI,L)+WAR*CH1(2,M2,KI,J) CC1(2,M1,KI,LC) = CC1(2,M1,KI,LC)+WAI*CH1(2,M2,KI,JC) 114 CONTINUE 115 CONTINUE 116 END DO IF (IDO .GT. 1) GO TO 136 SN = 1./REAL(IP*L1) IF (NA .EQ. 1) GO TO 146 DO 149 KI=1,LID M2 = M2S DO 149 M1=1,M1D,IM1 M2 = M2+IM2 CC1(1,M1,KI,1) = SN*CC1(1,M1,KI,1) CC1(2,M1,KI,1) = SN*CC1(2,M1,KI,1) 149 CONTINUE DO 120 J=2,IPPH JC = IPP2-J DO 119 KI=1,LID DO 119 M1=1,M1D,IM1 CHOLD1 = SN*(CC1(1,M1,KI,J)-CC1(2,M1,KI,JC)) CHOLD2 = SN*(CC1(1,M1,KI,J)+CC1(2,M1,KI,JC)) CC1(1,M1,KI,J) = CHOLD1 CC1(2,M1,KI,JC) = SN*(CC1(2,M1,KI,J)-CC1(1,M1,KI,JC)) CC1(2,M1,KI,J) = SN*(CC1(2,M1,KI,J)+CC1(1,M1,KI,JC)) CC1(1,M1,KI,JC) = CHOLD2 119 CONTINUE 120 END DO RETURN 146 DO 147 KI=1,LID M2 = M2S DO 147 M1=1,M1D,IM1 M2 = M2+IM2 CH1(1,M2,KI,1) = SN*CC1(1,M1,KI,1) CH1(2,M2,KI,1) = SN*CC1(2,M1,KI,1) 147 CONTINUE DO 145 J=2,IPPH JC = IPP2-J DO 144 KI=1,LID M2 = M2S DO 144 M1=1,M1D,IM1 M2 = M2+IM2 CH1(1,M2,KI,J) = SN*(CC1(1,M1,KI,J)-CC1(2,M1,KI,JC)) CH1(2,M2,KI,J) = SN*(CC1(2,M1,KI,J)+CC1(1,M1,KI,JC)) CH1(1,M2,KI,JC) = SN*(CC1(1,M1,KI,J)+CC1(2,M1,KI,JC)) CH1(2,M2,KI,JC) = SN*(CC1(2,M1,KI,J)-CC1(1,M1,KI,JC)) 144 CONTINUE 145 END DO RETURN 136 DO 137 KI=1,LID M2 = M2S DO 137 M1=1,M1D,IM1 M2 = M2+IM2 CH1(1,M2,KI,1) = CC1(1,M1,KI,1) CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 137 CONTINUE DO 135 J=2,IPPH JC = IPP2-J DO 134 KI=1,LID M2 = M2S DO 134 M1=1,M1D,IM1 M2 = M2+IM2 CH1(1,M2,KI,J) = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) 134 CONTINUE 135 END DO DO 131 I=1,IDO DO 130 K=1,L1 M2 = M2S DO 130 M1=1,M1D,IM1 M2 = M2+IM2 CC(1,M1,K,1,I) = CH(1,M2,K,I,1) CC(2,M1,K,1,I) = CH(2,M2,K,I,1) 130 CONTINUE 131 END DO DO 123 J=2,IP DO 122 K=1,L1 M2 = M2S DO 122 M1=1,M1D,IM1 M2 = M2+IM2 CC(1,M1,K,J,1) = CH(1,M2,K,1,J) CC(2,M1,K,J,1) = CH(2,M2,K,1,J) 122 CONTINUE 123 END DO DO 126 J=2,IP DO 125 I=2,IDO DO 124 K=1,L1 M2 = M2S DO 124 M1=1,M1D,IM1 M2 = M2+IM2 CC(1,M1,K,J,I) = WA(I,J-1,1)*CH(1,M2,K,I,J) & & +WA(I,J-1,2)*CH(2,M2,K,I,J) CC(2,M1,K,J,I) = WA(I,J-1,1)*CH(2,M2,K,I,J) & & -WA(I,J-1,2)*CH(1,M2,K,I,J) 124 CONTINUE 125 CONTINUE 126 END DO RETURN END