| 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: cmfgkb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $ |
|---|
| 11 | ! |
|---|
| 12 | !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC |
|---|
| 13 | |
|---|
| 14 | SUBROUTINE CMFGKB (LOT,IDO,IP,L1,LID,NA,CC,CC1,IM1,IN1, & |
|---|
| 15 | & CH,CH1,IM2,IN2,WA) |
|---|
| 16 | REAL CH(2,IN2,L1,IDO,IP) ,CC(2,IN1,L1,IP,IDO), & |
|---|
| 17 | & CC1(2,IN1,LID,IP) ,CH1(2,IN2,LID,IP) , & |
|---|
| 18 | & WA(IDO,IP-1,2) |
|---|
| 19 | ! |
|---|
| 20 | ! FFTPACK 5.0 auxiliary routine |
|---|
| 21 | ! |
|---|
| 22 | M1D = (LOT-1)*IM1+1 |
|---|
| 23 | M2S = 1-IM2 |
|---|
| 24 | IPP2 = IP+2 |
|---|
| 25 | IPPH = (IP+1)/2 |
|---|
| 26 | DO 110 KI=1,LID |
|---|
| 27 | M2 = M2S |
|---|
| 28 | DO 110 M1=1,M1D,IM1 |
|---|
| 29 | M2 = M2+IM2 |
|---|
| 30 | CH1(1,M2,KI,1) = CC1(1,M1,KI,1) |
|---|
| 31 | CH1(2,M2,KI,1) = CC1(2,M1,KI,1) |
|---|
| 32 | 110 CONTINUE |
|---|
| 33 | DO 111 J=2,IPPH |
|---|
| 34 | JC = IPP2-J |
|---|
| 35 | DO 112 KI=1,LID |
|---|
| 36 | M2 = M2S |
|---|
| 37 | DO 112 M1=1,M1D,IM1 |
|---|
| 38 | M2 = M2+IM2 |
|---|
| 39 | CH1(1,M2,KI,J) = CC1(1,M1,KI,J)+CC1(1,M1,KI,JC) |
|---|
| 40 | CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)-CC1(1,M1,KI,JC) |
|---|
| 41 | CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(2,M1,KI,JC) |
|---|
| 42 | CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(2,M1,KI,JC) |
|---|
| 43 | 112 CONTINUE |
|---|
| 44 | 111 END DO |
|---|
| 45 | DO 118 J=2,IPPH |
|---|
| 46 | DO 117 KI=1,LID |
|---|
| 47 | M2 = M2S |
|---|
| 48 | DO 117 M1=1,M1D,IM1 |
|---|
| 49 | M2 = M2+IM2 |
|---|
| 50 | CC1(1,M1,KI,1) = CC1(1,M1,KI,1)+CH1(1,M2,KI,J) |
|---|
| 51 | CC1(2,M1,KI,1) = CC1(2,M1,KI,1)+CH1(2,M2,KI,J) |
|---|
| 52 | 117 CONTINUE |
|---|
| 53 | 118 END DO |
|---|
| 54 | DO 116 L=2,IPPH |
|---|
| 55 | LC = IPP2-L |
|---|
| 56 | DO 113 KI=1,LID |
|---|
| 57 | M2 = M2S |
|---|
| 58 | DO 113 M1=1,M1D,IM1 |
|---|
| 59 | M2 = M2+IM2 |
|---|
| 60 | CC1(1,M1,KI,L) = CH1(1,M2,KI,1)+WA(1,L-1,1)*CH1(1,M2,KI,2) |
|---|
| 61 | CC1(1,M1,KI,LC) = WA(1,L-1,2)*CH1(1,M2,KI,IP) |
|---|
| 62 | CC1(2,M1,KI,L) = CH1(2,M2,KI,1)+WA(1,L-1,1)*CH1(2,M2,KI,2) |
|---|
| 63 | CC1(2,M1,KI,LC) = WA(1,L-1,2)*CH1(2,M2,KI,IP) |
|---|
| 64 | 113 CONTINUE |
|---|
| 65 | DO 115 J=3,IPPH |
|---|
| 66 | JC = IPP2-J |
|---|
| 67 | IDLJ = MOD((L-1)*(J-1),IP) |
|---|
| 68 | WAR = WA(1,IDLJ,1) |
|---|
| 69 | WAI = WA(1,IDLJ,2) |
|---|
| 70 | DO 114 KI=1,LID |
|---|
| 71 | M2 = M2S |
|---|
| 72 | DO 114 M1=1,M1D,IM1 |
|---|
| 73 | M2 = M2+IM2 |
|---|
| 74 | CC1(1,M1,KI,L) = CC1(1,M1,KI,L)+WAR*CH1(1,M2,KI,J) |
|---|
| 75 | CC1(1,M1,KI,LC) = CC1(1,M1,KI,LC)+WAI*CH1(1,M2,KI,JC) |
|---|
| 76 | CC1(2,M1,KI,L) = CC1(2,M1,KI,L)+WAR*CH1(2,M2,KI,J) |
|---|
| 77 | CC1(2,M1,KI,LC) = CC1(2,M1,KI,LC)+WAI*CH1(2,M2,KI,JC) |
|---|
| 78 | 114 CONTINUE |
|---|
| 79 | 115 CONTINUE |
|---|
| 80 | 116 END DO |
|---|
| 81 | IF(IDO.GT.1 .OR. NA.EQ.1) GO TO 136 |
|---|
| 82 | DO 120 J=2,IPPH |
|---|
| 83 | JC = IPP2-J |
|---|
| 84 | DO 119 KI=1,LID |
|---|
| 85 | DO 119 M1=1,M1D,IM1 |
|---|
| 86 | CHOLD1 = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) |
|---|
| 87 | CHOLD2 = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) |
|---|
| 88 | CC1(1,M1,KI,J) = CHOLD1 |
|---|
| 89 | CC1(2,M1,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) |
|---|
| 90 | CC1(2,M1,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) |
|---|
| 91 | CC1(1,M1,KI,JC) = CHOLD2 |
|---|
| 92 | 119 CONTINUE |
|---|
| 93 | 120 END DO |
|---|
| 94 | RETURN |
|---|
| 95 | 136 DO 137 KI=1,LID |
|---|
| 96 | M2 = M2S |
|---|
| 97 | DO 137 M1=1,M1D,IM1 |
|---|
| 98 | M2 = M2+IM2 |
|---|
| 99 | CH1(1,M2,KI,1) = CC1(1,M1,KI,1) |
|---|
| 100 | CH1(2,M2,KI,1) = CC1(2,M1,KI,1) |
|---|
| 101 | 137 CONTINUE |
|---|
| 102 | DO 135 J=2,IPPH |
|---|
| 103 | JC = IPP2-J |
|---|
| 104 | DO 134 KI=1,LID |
|---|
| 105 | M2 = M2S |
|---|
| 106 | DO 134 M1=1,M1D,IM1 |
|---|
| 107 | M2 = M2+IM2 |
|---|
| 108 | CH1(1,M2,KI,J) = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) |
|---|
| 109 | CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) |
|---|
| 110 | CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) |
|---|
| 111 | CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) |
|---|
| 112 | 134 CONTINUE |
|---|
| 113 | 135 END DO |
|---|
| 114 | IF (IDO .EQ. 1) RETURN |
|---|
| 115 | DO 131 I=1,IDO |
|---|
| 116 | DO 130 K=1,L1 |
|---|
| 117 | M2 = M2S |
|---|
| 118 | DO 130 M1=1,M1D,IM1 |
|---|
| 119 | M2 = M2+IM2 |
|---|
| 120 | CC(1,M1,K,1,I) = CH(1,M2,K,I,1) |
|---|
| 121 | CC(2,M1,K,1,I) = CH(2,M2,K,I,1) |
|---|
| 122 | 130 CONTINUE |
|---|
| 123 | 131 END DO |
|---|
| 124 | DO 123 J=2,IP |
|---|
| 125 | DO 122 K=1,L1 |
|---|
| 126 | M2 = M2S |
|---|
| 127 | DO 122 M1=1,M1D,IM1 |
|---|
| 128 | M2 = M2+IM2 |
|---|
| 129 | CC(1,M1,K,J,1) = CH(1,M2,K,1,J) |
|---|
| 130 | CC(2,M1,K,J,1) = CH(2,M2,K,1,J) |
|---|
| 131 | 122 CONTINUE |
|---|
| 132 | 123 END DO |
|---|
| 133 | DO 126 J=2,IP |
|---|
| 134 | DO 125 I=2,IDO |
|---|
| 135 | DO 124 K=1,L1 |
|---|
| 136 | M2 = M2S |
|---|
| 137 | DO 124 M1=1,M1D,IM1 |
|---|
| 138 | M2 = M2+IM2 |
|---|
| 139 | CC(1,M1,K,J,I) = WA(I,J-1,1)*CH(1,M2,K,I,J) & |
|---|
| 140 | & -WA(I,J-1,2)*CH(2,M2,K,I,J) |
|---|
| 141 | CC(2,M1,K,J,I) = WA(I,J-1,1)*CH(2,M2,K,I,J) & |
|---|
| 142 | & +WA(I,J-1,2)*CH(1,M2,K,I,J) |
|---|
| 143 | 124 CONTINUE |
|---|
| 144 | 125 CONTINUE |
|---|
| 145 | 126 END DO |
|---|
| 146 | RETURN |
|---|
| 147 | END |
|---|
