CTITLECEPCAL -- 3838 ARRAY PROCESSOR COMPLEX CEPSTRUM ROUTINE 00000010 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA 00000020 CA AUTHOR R. C. DECKER 00000030 CA DESIGNER R. C. DECKER 00000040 CA LANGUAGE S/370 FORTRAN H EXTENDED 00000050 C C REVISED FOR VS FORTRAN TRA 10-03-8400004400 C C REVISED FOR VS31 FORTRAN TRA 11-01-8400004400 C C RELEASED FOR PRODUCTION SPARC TRA 01-21-8500004400 C C CA CALLING SEQUENCE: 00000080 CA 00000090 CA CALL CEPCAL(TRACE,K,P) 00000100 CA 00000110 CA INPUT PARAMETERS: 00000120 CA 00000130 CA TRACE - INPUT TRACE SEGMENT R4 00000140 CA K - FFT LENGTH (POWER OF 2) (MIN=128,MAX=8192) I4 00000150 CA P - WHITE NOISE R4 00000160 CA 00000170 CA PURPOSE: THIS ROUTINE DEVELOPS A MIN-PHASE EQUIVALENT 00000180 CA CEPSTRUM FROM A TRACE SEGMENT. 00000190 CA 00000200 CA 00000210 CA 00000220 C PROCEDURE: 00000230 C 00000240 C 00000250 C 1. FFT TRACE = F (LENGTH K) 00000260 C 00000270 C 2. FORM CONJUGATE F*F = X (X WILL BE REAL ONLY) 00000280 C 00000290 C 3. SUM REAL COMPONENTS OF X = S 00000300 C 00000310 C 4. SCALE S BY P/K = Y 00000320 C 00000330 C 5. ADD Y TO X = X 00000340 C 00000350 C 6. TAKE LOG X = X 00000360 C 00000370 C 7. INVERSE FFT X = Z 00000380 C 00000390 C 8. SCALE Z BY 1./K 00000400 C 00000410 C 00000420 C BULK STORAGE: 00000430 C ______________________________ 00000440 C 0|____________________________| WHITE NOISE (R8) 00000450 C 1| | 00000460 C | |R8 = P/K 00000470 C | TRACE SEGMENT | 00000480 C | (K) | 00000490 C | | 00000500 C | | 00000510 C | R6 = K | 00000520 C | | 00000530 C | | 00000540 C |____________________________| 00000550 C |R1 | 00000560 C | | 00000570 C | FFT AREA | 00000580 C | (K+2) | 00000590 C | | 00000600 C | | 00000610 C | R1 = K + 1 | 00000620 C | R7 = K/2 + 1 | 00000630 C | | 00000640 C |____________________________| 00000650 C |R2 | 00000660 C | | 00000670 C | | 00000680 C | CMCC AREA | 00000690 C | (K+2) | 00000700 C | | 00000710 C | | 00000720 C | R2 = R1 + K + 2 | 00000730 C | | 00000740 C |____________________________| 00000750 C 00000760 C 00000770 C 00000780 C 00000790 C 00000800 C 00000810 SUBROUTINE CEPCAL(TRACE,K,P) 00000820 C 00000830 DIMENSION APBUF(8193) 00000840 DIMENSION TRACE(1), CIT(200), IREG(15), REGS(15) 00000850 REAL*8 CCW(200) 00000860 C 00000870 INTEGER R1,R2,R3,R4,R5,R6,R7,R8,R9,R10,R11,R12,R13,R14,R15 00000880 DATA R1/1/,R2/2/,R3/3/,R4/4/,R5/5/,R6/6/,R7/7/,R8/8/,R9/9/,R10/10/00001430 DATA R11/11/,R12/12/,R13/13/,R14/14/,R15/15/ 00001430 DATA ISTAT/3/, ISTATE/120/ 00000910 DATA KMAX/8192/ 00000920 C 00000930 C 00000940 C 00000950 EQUIVALENCE(IREG(1),REGS(1)) 00000960 EQUIVALENCE (IREG(1), NPFFT ) 00000970 EQUIVALENCE (IREG(2), NSCR ) 00000980 EQUIVALENCE (IREG(3), HALF ) 00000990 C EQUIVALENCE (IREG(4), ) 00001000 C EQUIVALENCE (IREG(5), ) 00001010 EQUIVALENCE (IREG(6), KS ) 00001020 EQUIVALENCE (IREG(7), KO2P1 ) 00001030 EQUIVALENCE (IREG(8), FFTNM ) 00001040 C EQUIVALENCE (IREG(9), ) 00001050 C EQUIVALENCE (IREG(10), ) 00001060 C EQUIVALENCE (IREG(11), ) 00001070 C EQUIVALENCE (IREG(12), ) 00001080 C EQUIVALENCE (IREG(13), ) 00001090 C EQUIVALENCE (IREG(14), ) 00001100 C EQUIVALENCE (IREG(15), ) 00001110 C 00001120 DATA IFIRST/0/ 00001130 KMAXP1 = KMAX + 1 00001140 C 00001150 IF(IFIRST.NE.0) GO TO 100 00001160 C 00001170 C GET A UNIT NUMBER FOR THE ARRAY PROCESSOR 00001180 C 00001190 KP1 = K + 1 00001200 NWDS = KMAX*3 + 5 00001210 CALL CSAPUN(NWDS,IU) 00001220 C 00001230 C 00001240 C START CONSTRUCTION OF THE 3838 PROGRAM 00001250 C 00001260 CALL VPSS(IU,'BLD ',ISTAT,CCW,200,CIT,200) 00001270 CALL VPSS(IU,'XWR ',REGS,15,1) 00001280 CALL VPSS(IU,'VPUT',APBUF,KMAXP1,0,0) 00001290 C 00001300 C FFT TRACE SEGMENT 00001310 C 00001320 CALL VPSS(IU,'FFTR',ISTATE, 00001330 * 96, 0, 0, R1, R7, 00001340 * 64, 1, 0, R6) 00001350 C 00001360 C MOVE CONSTANT 0.5 INTO ADDRESS (2) 00001370 C 00001380 CALL VPSS(IU, 'XMVX', 2, 1, 0, R3) 00001390 C 00001400 C SCALE THE FORWARD REAL FFT BY 0.5 00001410 C 00001420 CALL VPSS(IU, 'SMY ', ISTATE, 00001430 * 96, 0, 2, 1, R1, R6, 00001440 * 32, 0, 1, R1, 00001450 * 0, 2) 00001460 C 00001470 C CONJUGATE 00001480 C 00001490 CALL VPSS(IU,'CMCC',ISTATE, 00001500 * 96, 0, 0, R2, R7, 00001510 * 32, 0, R1) 00001520 C 00001530 C MOVE REAL RESULT INTO ADDRESS (1) 00001540 C 00001550 CALL VPSS(IU, 'VMV ', ISTATE, 00001560 * 64, 1, 0, 1, R7, 00001570 * 32, 0, 2, R2) 00001580 C 00001590 C REVERSE SYMMETRIC HALF AND POSITION FOR SUM 00001600 C 00001610 CALL VPSS(IU, 'REV ', ISTATE, 00001620 * 96, 1, -2, 1, R7, R7, 00001630 * 32, 2, 2, R2) 00001640 C 00001650 C 00001660 C 00001680 C 00001690 C SUM UP REAL COMPONENTS 00001700 C 00001710 CALL VPSS(IU,'SVE ',ISTATE, 00001720 * 0, 1, 00001730 * 64, 1, 0, 1, R6) 00001740 C 00001750 C MULTIPLY BY WHITE NOISE 00001760 C 00001770 CALL VPSS(IU,'VEM ',ISTATE, 00001780 * 0, 0, 1, 1, 00001790 * 0, 0, 1, 00001800 * 0, 1, 1) 00001810 C 00001820 C SUM EPSILON INTO THE CONJUGATE OUTPUT 00001830 C 00001840 CALL VPSS(IU, 'SSUM', ISTATE, 00001850 * 96, 0, 0, 1, R1, R7, 00001860 * 32, 0, 2, R2, 00001870 * 0, 0) 00001880 C 00001882 C 00001886 C 00001890 C TAKE LOG 00001900 C 00001910 CALL VPSS(IU, 'LOG ', ISTATE, 00001920 * 96, 0, 0, R1, R7, 00001930 * 32, 0, R1) 00001940 C 00001950 C MOVE LOG TO REAL COMPONENT 00001960 C 00001970 CALL VPSS(IU, 'VMV ', ISTATE, 00001980 * 96, 0, 0, 2, R2, R7, 00001990 * 32, 0, 1, R1) 00002000 C 00002010 C MOVE ZERO BACK INTO IMAGINARY COMPONENT 00002020 C 00002030 CALL VPSS(IU, 'ZMV ', ISTATE, 00002040 * 96, 1, 0, 2, R2, R7) 00002050 C 00002060 C 00002068 C INVERSE FFT 00002070 C 00002080 CALL VPSS(IU, 'IFTR', ISTATE, 00002090 * 64, 0, 0, R6, 00002100 * 96, 0, 0, R2, R7) 00002110 C 00002120 C MOVE FFT NORMALIZATION INTO MEMORY 00002130 C 00002140 CALL VPSS(IU, 'XMVX', 0, 1, R1, R8) 00002150 C 00002160 C SCALE THE FFT 00002170 C 00002180 CALL VPSS(IU, 'SMY ', ISTATE, 00002190 * 64, 0, 0, 1, R6, 00002200 * 0, 0, 1, 00002210 * 32, 0, R1) 00002220 C 00002230 C CLEAR OUT END OF CEPSTRUM 00002240 C 00002250 CALL VPSS(IU,'ZMV ', ISTATE, 00002260 * 96, 0, -2, 1, R7, R7) 00002270 C 00002280 C DIVIDE ZERO TIME SAMPLE BY 2.0 00002290 C 00002300 CALL VPSS(IU, 'XMVX', 0, 1, R1, R3) 00002310 C 00002320 CALL VPSS(IU, 'SMY ', ISTATE, 00002330 * 0, 0, 1, 1, 00002340 * 0, 0, 1, 00002350 * 32, 0, R1) 00002360 C 00002370 C RETREIVE DATA BACK INTO CPU 00002380 C 00002390 50 CALL VPSS(IU,'XRD ',REGS,15,1) 00002400 CALL VPSS(IU,'VGET',APBUF,KMAXP1,0,0) 00002410 CALL VPSS(IU,'XLTE',CEP1) 00002420 IFIRST = 1 00002430 C 00002440 C SET UP REGISTERS FOR 3838 00002450 C 00002460 100 NPFFT = K + 1 00002470 NSCR = NPFFT + K + 2 00002480 KS = K 00002490 KO2P1 = K/2 + 1 00002500 FFTNM = 1.0/FLOAT(K) 00002510 HALF = 0.5 00002520 C 00002530 C SET UP THE APBUF 00002540 C 00002550 APBUF(1) = P/K 00002560 CALL ARMVE(TRACE,APBUF(2),K) 00002570 C 00002580 C EXECUTE THE 3838 PROGRAM 00002590 C 00002600 CALL VPSS(IU,'EXCW',CEP1) 00002610 C 00002620 C 00002630 C WRITE(6,9000) 00002640 C9000 FORMAT(' AP BUFFER AFTER CEPCAL ') 00002650 C WRITE(6,9010) (APBUF(I),I=1,8192) 00002660 C9010 FORMAT(5X,10E12.3) 00002670 C 00002680 C MOVE THE OUTPUT CEPSTRUM INTO TRACE ARRAY 00002690 C 00002700 CALL ARMVE(APBUF,TRACE,K) 00002710 C 00002720 TRACE(K/2+1) = TRACE(K/2+1)/2.0 00002722 C 00002724 C 00002726 RETURN 00002730 END 00002740