mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
147 lines
4 KiB
Fortran
147 lines
4 KiB
Fortran
*DECK PASSF
|
|
SUBROUTINE PASSF (NAC, IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA)
|
|
C***BEGIN PROLOGUE PASSF
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Calculate the fast Fourier transform of subvectors of
|
|
C arbitrary length.
|
|
C***LIBRARY SLATEC (FFTPACK)
|
|
C***TYPE SINGLE PRECISION (PASSF-S)
|
|
C***AUTHOR Swarztrauber, P. N., (NCAR)
|
|
C***ROUTINES CALLED (NONE)
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 790601 DATE WRITTEN
|
|
C 830401 Modified to use SLATEC library source file format.
|
|
C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by
|
|
C changing dummy array size declarations (1) to (*).
|
|
C 881128 Modified by Dick Valent to meet prologue standards.
|
|
C 890831 Modified array declarations. (WRB)
|
|
C 891009 Removed unreferenced variable. (WRB)
|
|
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
|
C 900402 Added TYPE section. (WRB)
|
|
C***END PROLOGUE PASSF
|
|
DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), WA(*),
|
|
+ C2(IDL1,*), CH2(IDL1,*)
|
|
C***FIRST EXECUTABLE STATEMENT PASSF
|
|
IDOT = IDO/2
|
|
IPP2 = IP+2
|
|
IPPH = (IP+1)/2
|
|
IDP = IP*IDO
|
|
C
|
|
IF (IDO .LT. L1) GO TO 106
|
|
DO 103 J=2,IPPH
|
|
JC = IPP2-J
|
|
DO 102 K=1,L1
|
|
CDIR$ IVDEP
|
|
DO 101 I=1,IDO
|
|
CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
|
|
CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
|
|
101 CONTINUE
|
|
102 CONTINUE
|
|
103 CONTINUE
|
|
DO 105 K=1,L1
|
|
CDIR$ IVDEP
|
|
DO 104 I=1,IDO
|
|
CH(I,K,1) = CC(I,1,K)
|
|
104 CONTINUE
|
|
105 CONTINUE
|
|
GO TO 112
|
|
106 DO 109 J=2,IPPH
|
|
JC = IPP2-J
|
|
DO 108 I=1,IDO
|
|
CDIR$ IVDEP
|
|
DO 107 K=1,L1
|
|
CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
|
|
CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
|
|
107 CONTINUE
|
|
108 CONTINUE
|
|
109 CONTINUE
|
|
DO 111 I=1,IDO
|
|
CDIR$ IVDEP
|
|
DO 110 K=1,L1
|
|
CH(I,K,1) = CC(I,1,K)
|
|
110 CONTINUE
|
|
111 CONTINUE
|
|
112 IDL = 2-IDO
|
|
INC = 0
|
|
DO 116 L=2,IPPH
|
|
LC = IPP2-L
|
|
IDL = IDL+IDO
|
|
CDIR$ IVDEP
|
|
DO 113 IK=1,IDL1
|
|
C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
|
|
C2(IK,LC) = -WA(IDL)*CH2(IK,IP)
|
|
113 CONTINUE
|
|
IDLJ = IDL
|
|
INC = INC+IDO
|
|
DO 115 J=3,IPPH
|
|
JC = IPP2-J
|
|
IDLJ = IDLJ+INC
|
|
IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
|
|
WAR = WA(IDLJ-1)
|
|
WAI = WA(IDLJ)
|
|
CDIR$ IVDEP
|
|
DO 114 IK=1,IDL1
|
|
C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
|
|
C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
|
|
114 CONTINUE
|
|
115 CONTINUE
|
|
116 CONTINUE
|
|
DO 118 J=2,IPPH
|
|
CDIR$ IVDEP
|
|
DO 117 IK=1,IDL1
|
|
CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
|
|
117 CONTINUE
|
|
118 CONTINUE
|
|
DO 120 J=2,IPPH
|
|
JC = IPP2-J
|
|
CDIR$ IVDEP
|
|
DO 119 IK=2,IDL1,2
|
|
CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
|
|
CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
|
|
CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
|
|
CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
|
|
119 CONTINUE
|
|
120 CONTINUE
|
|
NAC = 1
|
|
IF (IDO .EQ. 2) RETURN
|
|
NAC = 0
|
|
CDIR$ IVDEP
|
|
DO 121 IK=1,IDL1
|
|
C2(IK,1) = CH2(IK,1)
|
|
121 CONTINUE
|
|
DO 123 J=2,IP
|
|
CDIR$ IVDEP
|
|
DO 122 K=1,L1
|
|
C1(1,K,J) = CH(1,K,J)
|
|
C1(2,K,J) = CH(2,K,J)
|
|
122 CONTINUE
|
|
123 CONTINUE
|
|
IF (IDOT .GT. L1) GO TO 127
|
|
IDIJ = 0
|
|
DO 126 J=2,IP
|
|
IDIJ = IDIJ+2
|
|
DO 125 I=4,IDO,2
|
|
IDIJ = IDIJ+2
|
|
CDIR$ IVDEP
|
|
DO 124 K=1,L1
|
|
C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
|
|
C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
|
|
124 CONTINUE
|
|
125 CONTINUE
|
|
126 CONTINUE
|
|
RETURN
|
|
127 IDJ = 2-IDO
|
|
DO 130 J=2,IP
|
|
IDJ = IDJ+IDO
|
|
DO 129 K=1,L1
|
|
IDIJ = IDJ
|
|
CDIR$ IVDEP
|
|
DO 128 I=4,IDO,2
|
|
IDIJ = IDIJ+2
|
|
C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
|
|
C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
|
|
128 CONTINUE
|
|
129 CONTINUE
|
|
130 CONTINUE
|
|
RETURN
|
|
END
|