1*DECK RADF4 2 SUBROUTINE RADF4 (IDO, L1, CC, CH, WA1, WA2, WA3) 3C***BEGIN PROLOGUE RADF4 4C***SUBSIDIARY 5C***PURPOSE Calculate the fast Fourier transform of subvectors of 6C length four. 7C***LIBRARY SLATEC (FFTPACK) 8C***TYPE SINGLE PRECISION (RADF4-S) 9C***AUTHOR Swarztrauber, P. N., (NCAR) 10C***ROUTINES CALLED (NONE) 11C***REVISION HISTORY (YYMMDD) 12C 790601 DATE WRITTEN 13C 830401 Modified to use SLATEC library source file format. 14C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by 15C (a) changing dummy array size declarations (1) to (*). 16C (b) changing definition of variable HSQT2 by using 17C FORTRAN intrinsic function SQRT instead of a DATA 18C statement. 19C 881128 Modified by Dick Valent to meet prologue standards. 20C 890831 Modified array declarations. (WRB) 21C 891214 Prologue converted to Version 4.0 format. (BAB) 22C 900402 Added TYPE section. (WRB) 23C***END PROLOGUE RADF4 24 DIMENSION CC(IDO,L1,4), CH(IDO,4,*), WA1(*), WA2(*), WA3(*) 25C***FIRST EXECUTABLE STATEMENT RADF4 26 HSQT2 = .5*SQRT(2.) 27 DO 101 K=1,L1 28 TR1 = CC(1,K,2)+CC(1,K,4) 29 TR2 = CC(1,K,1)+CC(1,K,3) 30 CH(1,1,K) = TR1+TR2 31 CH(IDO,4,K) = TR2-TR1 32 CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) 33 CH(1,3,K) = CC(1,K,4)-CC(1,K,2) 34 101 CONTINUE 35 IF (IDO-2) 107,105,102 36 102 IDP2 = IDO+2 37 IF((IDO-1)/2.LT.L1) GO TO 111 38 DO 104 K=1,L1 39CDIR$ IVDEP 40 DO 103 I=3,IDO,2 41 IC = IDP2-I 42 CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) 43 CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) 44 CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) 45 CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) 46 CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) 47 CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) 48 TR1 = CR2+CR4 49 TR4 = CR4-CR2 50 TI1 = CI2+CI4 51 TI4 = CI2-CI4 52 TI2 = CC(I,K,1)+CI3 53 TI3 = CC(I,K,1)-CI3 54 TR2 = CC(I-1,K,1)+CR3 55 TR3 = CC(I-1,K,1)-CR3 56 CH(I-1,1,K) = TR1+TR2 57 CH(IC-1,4,K) = TR2-TR1 58 CH(I,1,K) = TI1+TI2 59 CH(IC,4,K) = TI1-TI2 60 CH(I-1,3,K) = TI4+TR3 61 CH(IC-1,2,K) = TR3-TI4 62 CH(I,3,K) = TR4+TI3 63 CH(IC,2,K) = TR4-TI3 64 103 CONTINUE 65 104 CONTINUE 66 GO TO 110 67 111 DO 109 I=3,IDO,2 68 IC = IDP2-I 69CDIR$ IVDEP 70 DO 108 K=1,L1 71 CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) 72 CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) 73 CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) 74 CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) 75 CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) 76 CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) 77 TR1 = CR2+CR4 78 TR4 = CR4-CR2 79 TI1 = CI2+CI4 80 TI4 = CI2-CI4 81 TI2 = CC(I,K,1)+CI3 82 TI3 = CC(I,K,1)-CI3 83 TR2 = CC(I-1,K,1)+CR3 84 TR3 = CC(I-1,K,1)-CR3 85 CH(I-1,1,K) = TR1+TR2 86 CH(IC-1,4,K) = TR2-TR1 87 CH(I,1,K) = TI1+TI2 88 CH(IC,4,K) = TI1-TI2 89 CH(I-1,3,K) = TI4+TR3 90 CH(IC-1,2,K) = TR3-TI4 91 CH(I,3,K) = TR4+TI3 92 CH(IC,2,K) = TR4-TI3 93 108 CONTINUE 94 109 CONTINUE 95 110 IF (MOD(IDO,2) .EQ. 1) RETURN 96 105 DO 106 K=1,L1 97 TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) 98 TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) 99 CH(IDO,1,K) = TR1+CC(IDO,K,1) 100 CH(IDO,3,K) = CC(IDO,K,1)-TR1 101 CH(1,2,K) = TI1-CC(IDO,K,3) 102 CH(1,4,K) = TI1+CC(IDO,K,3) 103 106 CONTINUE 104 107 RETURN 105 END 106