1*DECK PASSB 2 SUBROUTINE PASSB (NAC, IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) 3C***BEGIN PROLOGUE PASSB 4C***SUBSIDIARY 5C***PURPOSE Calculate the fast Fourier transform of subvectors of 6C arbitrary length. 7C***LIBRARY SLATEC (FFTPACK) 8C***TYPE SINGLE PRECISION (PASSB-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 changing dummy array size declarations (1) to (*). 16C 881128 Modified by Dick Valent to meet prologue standards. 17C 890831 Modified array declarations. (WRB) 18C 891009 Removed unreferenced variable. (WRB) 19C 891214 Prologue converted to Version 4.0 format. (BAB) 20C 900402 Added TYPE section. (WRB) 21C***END PROLOGUE PASSB 22 DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), WA(*), 23 + C2(IDL1,*), CH2(IDL1,*) 24C***FIRST EXECUTABLE STATEMENT PASSB 25 IDOT = IDO/2 26 IPP2 = IP+2 27 IPPH = (IP+1)/2 28 IDP = IP*IDO 29C 30 IF (IDO .LT. L1) GO TO 106 31 DO 103 J=2,IPPH 32 JC = IPP2-J 33 DO 102 K=1,L1 34CDIR$ IVDEP 35 DO 101 I=1,IDO 36 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 37 CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 38 101 CONTINUE 39 102 CONTINUE 40 103 CONTINUE 41 DO 105 K=1,L1 42CDIR$ IVDEP 43 DO 104 I=1,IDO 44 CH(I,K,1) = CC(I,1,K) 45 104 CONTINUE 46 105 CONTINUE 47 GO TO 112 48 106 DO 109 J=2,IPPH 49 JC = IPP2-J 50 DO 108 I=1,IDO 51CDIR$ IVDEP 52 DO 107 K=1,L1 53 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 54 CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 55 107 CONTINUE 56 108 CONTINUE 57 109 CONTINUE 58 DO 111 I=1,IDO 59CDIR$ IVDEP 60 DO 110 K=1,L1 61 CH(I,K,1) = CC(I,1,K) 62 110 CONTINUE 63 111 CONTINUE 64 112 IDL = 2-IDO 65 INC = 0 66 DO 116 L=2,IPPH 67 LC = IPP2-L 68 IDL = IDL+IDO 69CDIR$ IVDEP 70 DO 113 IK=1,IDL1 71 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) 72 C2(IK,LC) = WA(IDL)*CH2(IK,IP) 73 113 CONTINUE 74 IDLJ = IDL 75 INC = INC+IDO 76 DO 115 J=3,IPPH 77 JC = IPP2-J 78 IDLJ = IDLJ+INC 79 IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP 80 WAR = WA(IDLJ-1) 81 WAI = WA(IDLJ) 82CDIR$ IVDEP 83 DO 114 IK=1,IDL1 84 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) 85 C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 86 114 CONTINUE 87 115 CONTINUE 88 116 CONTINUE 89 DO 118 J=2,IPPH 90CDIR$ IVDEP 91 DO 117 IK=1,IDL1 92 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 93 117 CONTINUE 94 118 CONTINUE 95 DO 120 J=2,IPPH 96 JC = IPP2-J 97CDIR$ IVDEP 98 DO 119 IK=2,IDL1,2 99 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) 100 CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) 101 CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 102 CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 103 119 CONTINUE 104 120 CONTINUE 105 NAC = 1 106 IF (IDO .EQ. 2) RETURN 107 NAC = 0 108 DO 121 IK=1,IDL1 109 C2(IK,1) = CH2(IK,1) 110 121 CONTINUE 111 DO 123 J=2,IP 112CDIR$ IVDEP 113 DO 122 K=1,L1 114 C1(1,K,J) = CH(1,K,J) 115 C1(2,K,J) = CH(2,K,J) 116 122 CONTINUE 117 123 CONTINUE 118 IF (IDOT .GT. L1) GO TO 127 119 IDIJ = 0 120 DO 126 J=2,IP 121 IDIJ = IDIJ+2 122 DO 125 I=4,IDO,2 123 IDIJ = IDIJ+2 124CDIR$ IVDEP 125 DO 124 K=1,L1 126 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) 127 C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 128 124 CONTINUE 129 125 CONTINUE 130 126 CONTINUE 131 RETURN 132 127 IDJ = 2-IDO 133 DO 130 J=2,IP 134 IDJ = IDJ+IDO 135 DO 129 K=1,L1 136 IDIJ = IDJ 137CDIR$ IVDEP 138 DO 128 I=4,IDO,2 139 IDIJ = IDIJ+2 140 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) 141 C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 142 128 CONTINUE 143 129 CONTINUE 144 130 CONTINUE 145 RETURN 146 END 147