| 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: rfftb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $ |
|---|
| 11 | ! |
|---|
| 12 | !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC |
|---|
| 13 | |
|---|
| 14 | SUBROUTINE RFFTB1 (N,IN,C,CH,WA,FAC) |
|---|
| 15 | REAL CH(*), C(IN,*), WA(N) ,FAC(15) |
|---|
| 16 | ! |
|---|
| 17 | NF = FAC(2) |
|---|
| 18 | NA = 0 |
|---|
| 19 | DO 10 K1=1,NF |
|---|
| 20 | IP = FAC(K1+2) |
|---|
| 21 | NA = 1-NA |
|---|
| 22 | IF(IP .LE. 5) GO TO 10 |
|---|
| 23 | IF(K1 .EQ. NF) GO TO 10 |
|---|
| 24 | NA = 1-NA |
|---|
| 25 | 10 END DO |
|---|
| 26 | HALF = .5 |
|---|
| 27 | HALFM = -.5 |
|---|
| 28 | MODN = MOD(N,2) |
|---|
| 29 | NL = N-2 |
|---|
| 30 | IF(MODN .NE. 0) NL = N-1 |
|---|
| 31 | IF (NA .EQ. 0) GO TO 120 |
|---|
| 32 | CH(1) = C(1,1) |
|---|
| 33 | CH(N) = C(1,N) |
|---|
| 34 | DO 118 J=2,NL,2 |
|---|
| 35 | CH(J) = HALF*C(1,J) |
|---|
| 36 | CH(J+1) = HALFM*C(1,J+1) |
|---|
| 37 | 118 END DO |
|---|
| 38 | GO TO 124 |
|---|
| 39 | 120 DO 122 J=2,NL,2 |
|---|
| 40 | C(1,J) = HALF*C(1,J) |
|---|
| 41 | C(1,J+1) = HALFM*C(1,J+1) |
|---|
| 42 | 122 END DO |
|---|
| 43 | 124 L1 = 1 |
|---|
| 44 | IW = 1 |
|---|
| 45 | DO 116 K1=1,NF |
|---|
| 46 | IP = FAC(K1+2) |
|---|
| 47 | L2 = IP*L1 |
|---|
| 48 | IDO = N/L2 |
|---|
| 49 | IDL1 = IDO*L1 |
|---|
| 50 | IF (IP .NE. 4) GO TO 103 |
|---|
| 51 | IX2 = IW+IDO |
|---|
| 52 | IX3 = IX2+IDO |
|---|
| 53 | IF (NA .NE. 0) GO TO 101 |
|---|
| 54 | CALL R1F4KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3)) |
|---|
| 55 | GO TO 102 |
|---|
| 56 | 101 CALL R1F4KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3)) |
|---|
| 57 | 102 NA = 1-NA |
|---|
| 58 | GO TO 115 |
|---|
| 59 | 103 IF (IP .NE. 2) GO TO 106 |
|---|
| 60 | IF (NA .NE. 0) GO TO 104 |
|---|
| 61 | CALL R1F2KB (IDO,L1,C,IN,CH,1,WA(IW)) |
|---|
| 62 | GO TO 105 |
|---|
| 63 | 104 CALL R1F2KB (IDO,L1,CH,1,C,IN,WA(IW)) |
|---|
| 64 | 105 NA = 1-NA |
|---|
| 65 | GO TO 115 |
|---|
| 66 | 106 IF (IP .NE. 3) GO TO 109 |
|---|
| 67 | IX2 = IW+IDO |
|---|
| 68 | IF (NA .NE. 0) GO TO 107 |
|---|
| 69 | ! rav CALL RIF3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2)) |
|---|
| 70 | CALL R1F3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2)) |
|---|
| 71 | GO TO 108 |
|---|
| 72 | 107 CALL R1F3KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2)) |
|---|
| 73 | 108 NA = 1-NA |
|---|
| 74 | GO TO 115 |
|---|
| 75 | 109 IF (IP .NE. 5) GO TO 112 |
|---|
| 76 | IX2 = IW+IDO |
|---|
| 77 | IX3 = IX2+IDO |
|---|
| 78 | IX4 = IX3+IDO |
|---|
| 79 | IF (NA .NE. 0) GO TO 110 |
|---|
| 80 | CALL R1F5KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2), & |
|---|
| 81 | & WA(IX3),WA(IX4)) |
|---|
| 82 | GO TO 111 |
|---|
| 83 | 110 CALL R1F5KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2), & |
|---|
| 84 | & WA(IX3),WA(IX4)) |
|---|
| 85 | 111 NA = 1-NA |
|---|
| 86 | GO TO 115 |
|---|
| 87 | 112 IF (NA .NE. 0) GO TO 113 |
|---|
| 88 | ! rav CALL RIFGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW)) |
|---|
| 89 | CALL R1FGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW)) |
|---|
| 90 | GO TO 114 |
|---|
| 91 | ! rav 113 CALL RIFGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW)) |
|---|
| 92 | 113 CALL R1FGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW)) |
|---|
| 93 | 114 IF (IDO .EQ. 1) NA = 1-NA |
|---|
| 94 | 115 L1 = L2 |
|---|
| 95 | IW = IW+(IP-1)*IDO |
|---|
| 96 | 116 END DO |
|---|
| 97 | RETURN |
|---|
| 98 | END |
|---|
