CTITLESAGFLT -- BANDPASS FILTER ROUTINE FOR 3838 ARRAY PROCESSOR 00000010 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA 00000020 CA AUTHOR R. D. KNIGHT 00000030 CA DESIGNER R. D. KNIGHT 00000040 CA LANGUAGE S/370 VS FORTRAN 00000050 CA WRITTEN 07/25/82 00000060 C REVISED 08-05-82 BY RDK; ADDED RECORD,TRACE TO 00000070 C CALL LIST. 00000080 C REVISED 10-06-82 BY RDK; ADDED APSTAT COMMON AND 00000083 C ERROR CHECKS. 00000086 C REVISED 10/10/84 NAM; VS FORTRAN CONVERSION. MAKE 00000087 C VPSS CALLING LITERALS FOUR 00000088 C CHARACTERS IN LENGTH. MOVE ALL 00000089 C DATA STATEMENTS AFTER VARIABLE 00000091 C DEFINATION STATEMENTS. 00000092 CA 00000093 CA CALL SAGFLT ( LX, X, FL, FH, DT, Y, IR, IT ) 00000100 CA 00000110 CA IN/OUT ARG TYPE DESCRIPTION 00000120 CA 00000130 CA IN LX I4 NUMBER OF ELEMENTS IN INPUT ARRAY 00000140 CA IN/OUT X R4 INPUT ARRAY (TRACE) 00000150 CA IN FL R4 LOW FREQUENCY TO PASS (HERTZ) 00000160 CA IN FH R4 HIGH FREQUENCY TO PASS (HERTZ) 00000170 CA IN DT R4 SAMPLE RATE OF THE DATA IN SECONDS 00000180 CA SCR Y R4 SCRATCH ARRAY OF LENGTH 8192 00000190 CA MUST BE SAME ON ALL CALLS TO SAGFLT 00000200 CA IN IR I4 CURRENT SHOT OR CDP NUMBER 00000210 CA IN IT I4 CURRENT TRACE NUMBER 00000220 CA 00000230 CA PURPOSE: 00000240 CA 00000250 CA THIS ROUTINE CONVOLVES THE INPUT TRACE ARRAY WITH A KLAUDER 00000260 CA WAVELET WITH SPECIFIED BANDPASS. A 4-POINT SECOND ORDER COSINE 00000270 CA TAPER IS APPLIED TO THE FREQUENCY LIMITS OF THE FILTERED TRACE. 00000280 CA 00000290 CA 00000300 CA SUBROUTINES CALLED : ARMVE (S1ATP) 00000310 CA CSAPUN 00000320 CA VPSS 00000330 CA 00000340 CA 00000350 CAEND 00000360 C 00000370 SUBROUTINE SAGFLT ( LX, X, FL, FH, DT, Y, IR, IT ) 00000380 C 00000383 COMMON /APSTAT/ KPRTF 00000386 C 00000390 DIMENSION REGS(15), IREG(15) 00000400 DIMENSION CIT(150) 00000410 DIMENSION X(1) 00000420 C 00000430 REAL*8 CCW(200) 00000440 COMPLEX TAPER (8) 00000450 DIMENSION Y(1) 00000460 EXTERNAL S1ATP 00000470 C 00000480 C 00000490 EQUIVALENCE (REGS(1),IREG(1)) 00000500 EQUIVALENCE (IREG(1) , L1 ) 00000510 EQUIVALENCE (IREG(2) , L2 ) 00000520 EQUIVALENCE (IREG(3) , L3 ) 00000530 EQUIVALENCE (REGS(4) , L4 ) 00000540 EQUIVALENCE (REGS(5) , L5 ) 00000550 EQUIVALENCE (IREG(6) , L6 ) 00000560 EQUIVALENCE (IREG(7) , L7 ) 00000570 EQUIVALENCE (IREG(8) , L8 ) 00000580 EQUIVALENCE (IREG(9) , L9 ) 00000590 CX EQUIVALENCE (IREG(10), ) 00000600 CX EQUIVALENCE (IREG(11), ) 00000610 C EQUIVALENCE (IREG(12), ) 00000620 C EQUIVALENCE (IREG(13), ) 00000630 EQUIVALENCE (IREG(14), L14 ) 00000640 EQUIVALENCE (IREG(15), L15 ) 00000650 C 00000660 C 00000670 INTEGER R1,R2,R3,R4,R5,R6,R7,R8,R9,R10,R11,R12,R13,R14,R15 00000671 DATA R1,R2,R3,R4,R5,R6,R7,R8,R9,R10,R11,R12,R13,R14,R15 00000672 */1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ 00000673 DATA ISTATE/120/ 00000680 DATA ISTAT/3/ 00000690 DATA IFIRST/0/ 00000700 DATA MAXL/ 8200/ 00000710 DATA TAPER/ (0.0954915,0.0), (0.3454915,0.0), (0.6545085,0.0), 00000750 * (0.9045085,0.0), (0.6545085,0.0), (0.3454915,0.0), 00000760 * (0.0954915,0.0), (0.0 ,0.0) / 00000770 C 00000780 C 00000790 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00000800 C SAGFLT ENTRY 00000810 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00000820 C 00000830 C 00000840 C REGISTER CONTENTS BULK STORAGE CONTENTS 00000850 C 00000860 C R1 = MAXL ADDR 2 - TAPER1, 0.0 00000870 C R2 = 2*MAXL 4 - TAPER2, 0.0 00000880 C R3 = 4*MAXL . TAPER3, 0.0 00000890 C R4 = ORIG DATA LENGTH . TAPER4, 0.0 00000900 C R5 = FFT LENGTH . TAPER3, 0.0 00000910 C R6 = 2*FFT LENGTH . TAPER2, 0.0 00000920 C R7 = BANDWIDTH INDEX 1 . TAPER1, 0.0 00000930 C R8 = BANDWIDTH INDEX 2 16 - 2/N , 0.0 00000940 C R9 = LENGTH OF BANDWIDTH 18-19 - NOT USED 00000950 C R10= R7+R2 20 - FFT AREA 1 00000960 C R11= R8 - (BANDWIDTH-1) 16420 - FFT AREA 2 00000970 C 00000980 C 00000990 C 00001000 C 00001010 IF(IFIRST.NE.0) GO TO 50 00001020 C 00001030 C FORWARD COMPLEX PROGRAM 00001040 C GET A UNIT NUMBER FOR 3838 00001050 C 00001060 NWDS = 33000 00001070 CALL CSAPUN(NWDS,IU) 00001080 NWDS = 8192 00001090 C 00001100 C 00001110 C BUILD THE 3838 PROGRAM FOR FORWARD COMPLEX FFT 00001120 C 00001130 CALL VPSS(IU,'BLD ',ISTAT,CCW,200,CIT,150) 00001140 C 00001150 C TRANSFER REGISTERS AND DATA TO 3838 00001160 C 00001170 CALL VPSS(IU,'XWR ' ,REGS,15,1) 00001180 CALL VPSS(IU,'XMV ' ,R10,R7 ) 00001190 CALL VPSS(IU,'XAD ' ,R10,R2 ) 00001200 CALL VPSS(IU,'XMV ' ,R11,R8 ) 00001210 CALL VPSS(IU,'XSBI',R11, 6 ) 00001220 C 00001230 C DATA INTO B 00001240 C 00001250 CALL VPSS(IU,'VPUT',TAPER, 16, 2, 0) 00001260 CALL VPSS(IU,'VPUT', Y,NWDS,20,R2) 00001270 C 00001280 C ZERO A 00001290 C 00001300 CALL VPSS(IU,'ZMV ',ISTATE, 00001310 * 64, 20, 0, 1, R6) 00001320 C 00001330 C B INTO A WITH DOUBLE SPACING 00001340 C 00001350 CALL VPSS(IU,'VMV ',ISTATE, 00001360 * 64, 20, 0, 2, R4, 00001370 * 32, 20, 1, R2 ) 00001380 C 00001390 C PUT FFT IN B 00001400 C 00001410 CALL VPSS(IU,'FFTC',ISTATE, 00001420 * 96, 20, 0, R2, R5, 00001430 * 0, 20 ) 00001440 C 00001450 C ZERO OUT A 00001460 C 00001470 CALL VPSS(IU,'ZMV ',ISTATE, 00001480 * 64, 20, 0, 1, R6 ) 00001490 C 00001500 C NORMALIZED BANDWIDTH FROM B TO A WITH CONJUGATION 00001510 C 00001520 CALL VPSS(IU,'SCMC',ISTATE, 00001530 * 96, 20, 0, R7, R9, 00001540 * 32, 20, R10, 00001550 * 0, 16 ) 00001560 C 00001570 C TAPER LEFT 00001580 C 00001590 CALL VPSS(IU,'CEM ',ISTATE, 00001600 * 32, 20, 4, R7, 00001610 * 32, 20, R7, 00001620 * 0, 2 ) 00001630 C 00001640 C TAPER RIGHT 00001650 C 00001660 CALL VPSS(IU,'CEM ',ISTATE, 00001670 * 32, 20, 4, R11, 00001680 * 32, 20, R11, 00001690 * 0, 8 ) 00001700 C 00001710 C FFT IN B 00001720 C 00001730 CALL VPSS(IU,'FFTC',ISTATE, 00001740 * 96, 20, 0, R2, R5, 00001750 * 0, 20 ) 00001760 C 00001770 C MOVE REAL PART TO A 00001780 C 00001790 CALL VPSS(IU,'VMV ',ISTATE, 00001800 * 64, 20, 0, 1, R4, 00001810 * 32, 20, 2, R2 ) 00001820 C 00001830 C GET RESULTS BACK INTO 370 00001840 C 00001850 CALL VPSS(IU,'VGET',Y,NWDS,20,0) 00001860 C 00001870 C TRANSLATE THE 3838 PROGRAM 00001880 C 00001890 CALL VPSS(IU,'XLTE',FCFFT) 00001900 C 00001910 IFIRST = 1 00001920 C 00001930 C 00001940 50 CALL S1FMAG ( LX, NEXP, N ) 00001950 C 00001960 N2 = N/2 + 1 00001970 DF = 1./(N*DT) 00001980 NL = 1.05 + FL/DF 00001990 IF(NL.EQ.1 .AND. FL.GT.0.) NL=2 00002000 NH = 1.05 + FH/DF 00002010 C 00002020 L1 = MAXL 00002030 L2 = 2*MAXL 00002040 L3 = 4*MAXL 00002050 L4 = LX 00002060 L5 = N 00002070 L6 = 2*N 00002080 L7 = (NL-1)*2 00002090 L8 = (NH-1)*2 00002100 L9 = NH-NL+1 00002110 C 00002120 L14= IR 00002130 L15= IT 00002140 C 00002150 TAPER(8) = CMPLX ( 2.0/N, 0.0 ) 00002160 C 00002163 KPORIG = 0 00002166 C 00002170 C PUT THE REAL AND IMAG DATA INTO Y IN COMPLEX FORM 00002180 C 00002190 60 KPRTF = KPORIG 00002195 CALL ARMVE( X, Y, LX ) 00002200 C 00002210 C EXECUTE THE APPROPRIATE 3838 PROGRAM 00002220 C 00002230 CALL VPSS(IU,'EXCW',FCFFT) 00002240 C 00002243 IF (KPRTF.LT.0) GO TO 60 00002246 C 00002250 C DEMULTIPLEX THE DATA FROM Y INTO A AND B 00002260 C 00002270 CALL ARMVE( Y, X, LX ) 00002280 C 00002290 RETURN 00002300 C 00002310 END 00002320