CTITLESAGACC -- 3838 ARRAY PROCESSOR CONVOLUTION 00000020 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR R. C. DECKER AOGC R&D 00000030 CA DESIGNER R. C. DECKER 00000040 CA LANGUAGE VS FORTRAN 00000050 CA SYSTEM S/370 00000060 CA WRITTEN 9/15/78 00000070 C REVISED JUL 82 -- REVISED FOR SPARC BY RDK 00000080 C REVISED 10/6/82-- ADD APSTAT COMMON BLOCK AND ERROR CHECKS 00000085 C REVISED 10/10/84-- NAM. VS FORTRAN CONVERSION. MAKE SURE 00000086 C ALL LITERALS IN VPSS CALLS ARE 00000087 C FOUR CHARACTERS IN LENGTH. MOVE 00000088 C ALL DATA STATEMENTS AFTER VARIABLE 00000089 C DEFINATION STATEMENTS. 00000090 C REVISED 10/30/84-- REP. CHANGE LENB TO LLENB IN ARG LISTS. 00000091 C ALSO LAG TO LLAG. 00000092 CA 00000093 CA CALL SAGACC ( A,LENA,B,LENB,C,LENC,LAG, X,U ) 00000100 CA 00000110 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00000120 CA 00000130 CA IN A R4 INPUT DATA ARRAY 00000140 CA IN LENA R4 LENGTH OF ARRAY A 00000150 CA IN B I4 INPUT DATA ARRAY 00000160 CA IN LENB R4 LENGTH OF ARRAY B 00000170 CA OUT C R4 OUTPUT DATA ARRAY 00000180 CA OUT LENC R4 LENGTH OF ARRAY C 00000190 CA IN LAG I4 NUMBER OF LAGS 00000200 CA IN X R4 SCRATCH ARRAY OF LENGTH 8192 00000210 CA MUST BE SAME ARRAY ON ALL CALLS 00000220 CA IN U R4 SCRATCH ARRAY OF LENGTH 8192 00000230 CA MUST BE SAME ARRAY ON ALL CALLS 00000240 CA 00000250 CA THIS PROGRAM PERFORMS A CONVOLVING MULTIPLY OF ARRAYS A AND B 00000260 CA PRODUCING ARRAY C. THIS ROUTINE USES THE 3838 ARRAY PROCESSOR 00000270 CA TO PERFORM THE CONVOLUTION. INSERT AN 'EXTERNAL SAGACC' STATE- 00000280 CA MENT IN THE CALLING PROGRAM IF SAGAC2 OR SAGAC3 ARE CALLED. 00000290 CA 00000300 CA LAG DEFINITION 00000310 CA ============== 00000320 CA 00000330 CA LAG = 0 00000340 CA X X X X X X X X X X X X 00000350 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00000360 CA B3 B2 B1 00000370 CA 00000380 CA LAG = 3 00000390 CA X X X X X X X X X 00000400 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00000410 CA B3 B2 B1 00000420 CA 00000430 CA LAG = -3 00000440 CA X X X X X X X X X X X X X X X 00000450 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00000460 CA B3 B2 B1 00000470 CA 00000480 CA SUBROUTINES CALLED: ARMVE (S1ATP) 00000490 CA CSAPUN 00000500 CA VPSS 00000510 CA 00000520 CA 00000530 C EJECT 00000540 C ===================================================================== 00000550 CTITLE SAGAC2 -- 3838 ARRAY PROCESSOR CROSSCORRELATION 00000560 CA AUTHOR R. C. DECKER AOGC R&D 00000570 CA DESIGNER R. C. DECKER 00000580 CA LANGUAGE FORTRAN H 00000590 CA SYSTEM S/370 00000600 CA WRITTEN 9/15/78 00000610 C REVISED JUL 82 -- REVISED FOR SPARC BY RDK 00000620 CA 00000630 CA CALL SAGAC2 ( A,LENA,B,LENB,C,LENC,LAG, X,U ) 00000640 CA 00000650 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00000660 CA 00000670 CA IN A R4 INPUT DATA ARRAY 00000680 CA IN LENA R4 LENGTH OF ARRAY A 00000690 CA IN B I4 INPUT DATA ARRAY 00000700 CA IN LENB R4 LENGTH OF ARRAY B 00000710 CA OUT C R4 OUTPUT DATA ARRAY 00000720 CA OUT LENC R4 LENGTH OF ARRAY C 00000730 CA IN LAG I4 NUMBER OF LAGS 00000740 CA IN X R4 SCRATCH ARRAY OF LENGTH 8192 00000750 CA MUST BE SAME ARRAY ON ALL CALLS 00000760 CA IN U R4 SCRATCH ARRAY OF LENGTH 8192 00000770 CA MUST BE SAME ARRAY ON ALL CALLS 00000780 CA 00000790 CA THIS PROGRAM PERFORMS A CONVOLVING MULTIPLY OF ARRAYS A AND B 00000800 CA PRODUCING ARRAY C. THIS ROUTINE USES THE 3838 ARRAY PROCESSOR 00000810 CA TO PERFORM THE CORRELATION. INSERT AN 'EXTERNAL SAGACC' STATE- 00000820 CA MENT IN THE CALLING PROGRAM WHEN CALLING SAGAC2. 00000830 CA 00000840 CA LAG DEFINITION 00000850 CA ============== 00000860 CA 00000870 CA LAG = 0 00000880 CA X X X X X X X X X X X X 00000890 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00000900 CA B1 B2 B3 00000910 CA 00000920 CA LAG = 3 00000930 CA X X X X X X X X X 00000940 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00000950 CA B1 B2 B3 00000960 CA 00000970 CA LAG = -3 00000980 CA X X X X X X X X X X X X X X X 00000990 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00001000 CA B1 B2 B3 00001010 CA 00001020 CA SUBROUTINES CALLED: ARMVE (S1ATP) 00001030 CA CSAPUN 00001040 CA VPSS 00001050 CA 00001060 CA 00001070 C EJECT 00001080 C ===================================================================== 00001090 CTITLE SAGAC3 -- 3838 ARRAY PROCESSOR AUTOCORRELATION 00001100 CA AUTHOR R. C. DECKER AOGC R&D 00001110 CA DESIGNER R. C. DECKER 00001120 CA LANGUAGE FORTRAN H 00001130 CA SYSTEM S/370 00001140 CA WRITTEN 9/15/78 00001150 C REVISED JUL 82 -- REVISED FOR SPARC BY RDK 00001160 CA 00001170 CA CALL SAGAC3 ( A,LENA,C,LENC, X,U ) 00001180 CA 00001190 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00001200 CA 00001210 CA IN A R4 INPUT DATA ARRAY 00001220 CA IN LENA R4 LENGTH OF ARRAY A 00001230 CA OUT C R4 OUTPUT DATA ARRAY 00001240 CA OUT LENC R4 LENGTH OF ARRAY C 00001250 CA IN X R4 SCRATCH ARRAY OF LENGTH 8192 00001260 CA MUST BE SAME ARRAY ON ALL CALLS 00001270 CA IN U R4 SCRATCH ARRAY OF LENGTH 8192 00001280 CA MUST BE SAME ARRAY ON ALL CALLS 00001290 CA 00001300 CA THIS PROGRAM PERFORMS A CONVOLVING MULTIPLY OF ARRAYS A AND B 00001310 CA PRODUCING ARRAY C. THIS ROUTINE USES THE 3838 ARRAY PROCESSOR 00001320 CA TO PERFORM THE CORRELATION. INSERT AN 'EXTERNAL SAGACC' STATE- 00001330 CA MENT IN THE CALLING PROGRAM WHEN CALLING SAGAC3. 00001340 CA 00001350 CA LAG DEFINITION 00001360 CA ============== 00001370 CA 00001380 CA LAG = 0 00001390 CA X X X X X X X X X X X X 00001400 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00001410 CA B1 B2 B3 00001420 CA 00001430 CA LAG = 3 00001440 CA X X X X X X X X X 00001450 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00001460 CA B1 B2 B3 00001470 CA 00001480 CA LAG = -3 00001490 CA X X X X X X X X X X X X X X X 00001500 CA A1 A2 A3 A4 A5 A6 A7 A8 A9 00001510 CA B1 B2 B3 00001520 CA 00001530 CA SUBROUTINES CALLED: ARMVE (S1ATP) 00001540 CA CSAPUN 00001550 CA VPSS 00001560 CA 00001570 CA 00001580 CAEND 00001590 C ===================================================================== 00001600 C 00001610 C 00001620 C 00001630 SUBROUTINE SAGACC ( A,LENA,B,LLENB,C,LENC,LLAG,X,U ) 00001640 C 00001642 COMMON /APSTAT/ KPRTF 00001644 C 00001650 DIMENSION REGS(15), IREG(15), X(1), U(1) 00001660 DIMENSION CIT1(200),CIT2(200),CIT3(200),CIT4(200) 00001670 DIMENSION A(1), B(1), C(1) 00001680 REAL*8 CCW(200) 00001690 C 00001700 C 00001710 EQUIVALENCE (REGS(1),IREG(1)) 00001720 EQUIVALENCE (IREG(1) , IC ) 00001730 EQUIVALENCE (IREG(2) , IB ) 00001740 EQUIVALENCE (IREG(3) , INDXZ1) 00001750 EQUIVALENCE (IREG(4) , IUADR ) 00001760 EQUIVALENCE (IREG(5) , IXADR ) 00001770 EQUIVALENCE (IREG(6) , FACT ) 00001780 EQUIVALENCE (IREG(7) , IRET ) 00001790 EQUIVALENCE (IREG(8) , INDXZ ) 00001800 EQUIVALENCE (IREG(9) , LENZ ) 00001810 EQUIVALENCE (IREG(10), LENCA ) 00001820 EQUIVALENCE (IREG(11), L ) 00001830 EQUIVALENCE (IREG(12), LENZ1 ) 00001840 EQUIVALENCE (IREG(13), IFFTX ) 00001850 EQUIVALENCE (IREG(14), IFFTU ) 00001860 EQUIVALENCE (IREG(15), LENFFT) 00001870 C 00001880 C 00001890 INTEGER R1 /1/ 00001891 INTEGER R2 /2/ 00001892 INTEGER R3 /3/ 00001893 INTEGER R4 /4/ 00001894 INTEGER R5 /5/ 00001895 INTEGER R6 /6/ 00001896 INTEGER R7 /7/ 00001897 INTEGER R8 /8/ 00001898 INTEGER R9 /9/ 00001899 INTEGER R10 /10/ 00001900 INTEGER R11 /11/ 00001901 INTEGER R12 /12/ 00001902 INTEGER R13 /13/ 00001903 INTEGER R14 /14/ 00001904 INTEGER R15 /15/ 00001905 DATA ISTATE/120/ 00001909 DATA ISTAT/3/ 00001910 DATA IFLAG1/0/, IFLAG2/0/ 00001920 C 00001960 C 00001961 C SET LOCAL VARIABLE FOR LENB & LAG 00001962 LENB = LLENB 00001963 LAG = LLAG 00001964 C 00001965 C DETERMINE WHETHER CONVOLUTION SHOULD BE DONE 00001970 C IN TIME OR FREQUENCY DOMAIN. 00001980 C 00001990 ITYPE = 0 00002000 IF(LENB.GT.60) ITYPE = 1 00002010 IA = LENA 00002020 IB = LENB 00002030 IC = LENC 00002040 C 00002050 C 00002060 C CHECK IF 3838 PROGRAM HAS BEEN TRANSLATED 00002070 C 00002080 C 00002090 IF(IFLAG1.NE.0) GO TO 100 00002100 C 00002110 C GET A UNIT NUMBER FOR 3838 00002120 C 00002130 NWDS = 4 * 8192 + 4 00002140 CALL CSAPUN(NWDS,IU) 00002150 C 00002160 C 00002170 C BUILD AND TRANSLATE THE 3838 PROGRAM 00002180 C TIME DOMAIN CONVOLUTION 00002190 C 00002200 CALL VPSS(IU,'BLD ',ISTAT,CCW,200,CIT1,200) 00002210 C 00002220 C 00002230 CALL VPSS(IU,'XWR ',REGS,15,1) 00002240 CALL VPSS(IU,'VPUT',X,8192,0,R5) 00002250 CALL VPSS(IU,'VPUT',U,8192,0,R4) 00002260 C 00002270 C 00002280 C CLEAR OUT ELEMENTS AT BEGINNING AND END OF A 00002290 C 00002300 CALL VPSS(IU,'ZMV ',ISTATE, 00002310 * 64,0,0,1,R5) 00002320 CALL VPSS(IU,'ZMV ',ISTATE, 00002330 * 96,0,0,1,R8,R9) 00002340 C 00002350 C REVERSE THE U VECTOR FOR CONVOLUTION 00002360 C 00002370 CALL VPSS(IU,'REV ',ISTATE, 00002380 * 96,0,0,1,R4,R2, 00002390 * 32,0,1,R4) 00002400 C 00002410 C CONVOLVING MULTIPLY (CONVOLUTION ) 00002420 C 00002430 CALL VPSS(IU,'CVM ',ISTATE, 00002440 * 96,0,0,1,R7,R1, 00002450 * 64,1,0,1,R10, 00002460 * 96,0,0,1,R4,R2) 00002470 C 00002480 C 00002490 CALL VPSS(IU,'VGET',X,8192,0,R7) 00002500 C 00002510 CALL VPSS(IU,'XLTE',TUSCNV) 00002520 C 00002530 C ===================================================================== 00002540 C END OF 3838 PROGRAM FOR TIME DOMAIN CONVOLUTION 00002550 C ===================================================================== 00002560 C 00002570 C BUILD THE 3838 PROGRAM FOR FREQUENCY DOMAIN CONVOLUTION 00002580 C 00002590 CALL VPSS(IU,'BLD ',ISTAT,CCW,200,CIT2,200) 00002600 C 00002610 C TRANSFER REGISTERS AND DATA TO 3838 00002620 C 00002630 CALL VPSS(IU,'XWR ',REGS,15,1) 00002640 CALL VPSS(IU,'VPUT',X,8192,0,R5) 00002650 CALL VPSS(IU,'VPUT',U,8192,0,R4) 00002660 C 00002670 C PAD ZEROES IN X AND U BUFFERS 00002680 C 00002690 CALL VPSS(IU,'ZMV ',ISTATE, 00002700 * 64,0,0,1,R5) 00002710 CALL VPSS(IU,'ZMV ',ISTATE, 00002720 * 96,0,0,1,R8,R9) 00002730 CALL VPSS(IU,'ZMV ',ISTATE, 00002740 * 96,0,0,1,R3,R12) 00002750 C 00002760 C EXECUTE FFT ON X AND U BUFFERS 00002770 C 00002780 CALL VPSS(IU,'FFTR',ISTATE, 00002790 * 96,0,0,R13,R15, 00002800 * 64,1,0,R11) 00002810 C * 00002820 CALL VPSS(IU,'FFTR',ISTATE, 00002830 * 96,0,0,R14,R15, 00002840 * 96,0,0,R4,R11) 00002850 C 00002860 C MULTIPLY FFT OUTPUTS (COMPLEX MULTIPLY WITH COMJUGATE 00002870 C OUTPUT) 00002880 C 00002890 CALL VPSS(IU,'CMCO',ISTATE, 00002900 * 96,0,0,R13,R15, 00002910 * 32,0,R13, 00002920 * 32,0,R14) 00002930 C 00002940 C EXECUTE THE INVERSE FFT ON CONJUGATE PRODUCT 00002950 C 00002960 CALL VPSS(IU,'IFTR',ISTATE, 00002970 * 64,0,0,R11, 00002980 * 96,0,0,R13,R15) 00002990 C 00003000 C NORMALIZE OUTPUT 00003010 C 00003020 CALL VPSS(IU,'XMVX',0,1,R13,R6) 00003030 C 00003040 CALL VPSS(IU,'SMY ',ISTATE, 00003050 * 64,0,0,1,R11, 00003060 * 0,0,1, 00003070 * 32,0,R13) 00003080 C 00003090 C GET RESULTS BACK INTO 370 00003100 C 00003110 CALL VPSS(IU,'VGET',X,8192,0,R7) 00003120 C 00003130 C TRANSLATE THE 3838 PROGRAM 00003140 C 00003150 CALL VPSS(IU,'XLTE',FUSCNV) 00003160 C 00003170 C =================================================================== 00003180 C END OF 3838 PROGRAM FOR FREQUENCY DOMAIN CONVOLUTION 00003190 C =================================================================== 00003200 C 00003210 IFLAG1 = 1 00003220 C 00003230 100 IF(ITYPE.EQ.1) GO TO 200 00003240 C 00003250 C ==================================================================== 00003260 C PROCESS THE INPUT DATA 00003270 C TIME DOMAIN CONVOLUTION 00003280 C ==================================================================== 00003290 C 00003300 C CALCULATE ADDRESS IN BULK STORAGE FOR X 00003310 C 00003320 NDX = 1 00003330 MOVEL = LENA 00003340 C 00003350 IF(LAG.LE.0) IXADR = LENB + IABS(LAG) + 1 00003360 IF(LAG.GT.0) IXADR = LENB - LAG + 1 00003370 C 00003380 C 00003390 IF(IXADR.GT.0) GO TO 150 00003400 NDX = IABS(LENB-LAG) + 1 00003410 MOVEL = LENA - NDX + 1 00003420 IF(MOVEL.GT.0) GO TO 140 00003430 CALL ARSET(C,LENC,0.0) 00003440 RETURN 00003450 C 00003460 C 00003470 140 IXADR = 1 00003480 C 00003490 150 INDXZ = IXADR + MOVEL 00003500 LENCA = LENC + LENB - 1 00003510 IF(LENCA.LE.MOVEL) LENZ = 1 00003520 IF(LENCA.GT.MOVEL) LENZ = LENCA - MOVEL 00003530 IUADR = INDXZ + LENZ 00003540 IRET = IUADR + LENB 00003550 C 00003553 KPORIG = 0 00003556 C 00003560 160 KPRTF = KPORIG 00003570 CALL ARMVE(A(NDX),X,MOVEL) 00003580 CALL ARMVE(B,U,LENB) 00003590 C 00003600 C EXECUTE THE 3838 PROGRAM 'TUSCNV' 00003610 C 00003620 CALL VPSS(IU,'EXCW',TUSCNV) 00003630 C 00003633 IF (KPRTF.LT.0) GO TO 160 00003636 C 00003640 C MOVE RESULTS INTO OUTPUT AREA C 00003650 C 00003660 CALL ARMVE(X,C,LENC) 00003670 C 00003680 C WRITE(6,5060) (X(I),I=1,8192) 00003690 C5060 FORMAT(1X,10F10.2) 00003700 C 00003710 RETURN 00003720 C 00003730 C ==================================================================== 00003740 C PROCESS THE INPUT DATA 00003750 C FREQUENCY DOMAIN CONVOLUTION 00003760 C ==================================================================== 00003770 C 00003780 C CALCULATE THE ADDRESS IN BULK STORAGE FOR X 00003790 C 00003800 200 NDX = 1 00003810 MOVEL = LENA 00003820 C 00003830 IF(LAG.LE.0) IXADR = LENB + IABS(LAG) + 1 00003840 IF(LAG.GT.0) IXADR = LENB - LAG + 1 00003850 C 00003860 C 00003870 IF(IXADR.GT.0) GO TO 250 00003880 NDX = IABS(LENB-LAG) + 1 00003890 MOVEL = LENA - NDX + 1 00003900 IF(MOVEL.GT.0) GO TO 240 00003910 CALL ARSET(C,LENC,0.0) 00003920 RETURN 00003930 C 00003940 C 00003950 240 IXADR = 1 00003960 C 00003970 C CALCULATE INDEX FOR ZERO PADDING 00003980 C 00003990 250 LENCA = LENC + LENB - 1 00004000 INDXZ = IXADR + MOVEL 00004010 IF(INDXZ.GT.LENCA+1) INDXZ = LENCA + 1 00004020 C 00004030 C FIND THE POWER OF 2 LARGER THAN THE LENGTH 00004040 C CALCULATED FOR A (LENCA). 00004050 C 00004060 LL = 6 00004070 L = 64 00004080 260 IF(L.GE.LENCA) GO TO 270 00004090 LL = LL + 1 00004100 L = L * 2 00004110 GO TO 260 00004120 C 00004130 C CALCULATE LENGTH FOR PADDING ZEROES IN X 00004140 C 00004150 270 LENZ = L - INDXZ + 1 00004160 C 00004170 C CALCULATE ADDRESS TO LOAD U BUFFER AND ADDRESS AND 00004180 C LENGTH FOR ZERO PADDING 00004190 C 00004200 IUADR = INDXZ + LENZ + 1 00004210 INDXZ1 = IUADR + LENB 00004220 LENZ1 = L - LENB 00004230 C 00004240 C CALCULATE POINTERS IN BULK STORAGE FOR FFT OUTPUT 00004250 C 00004260 IFFTX = IUADR + L 00004270 IFFTU = IFFTX + L + 2 00004280 LENFFT = L/2 + 1 00004290 FACT = 1.0/(4.0*L) 00004300 IRET = LENB - 1 00004310 C 00004313 KPORIG = 0 00004316 C 00004320 272 KPRTF = KPORIG 00004325 CALL ARMVE(A(NDX),X,MOVEL) 00004330 CALL ARMVE(B,U,LENB) 00004340 C 00004350 C EXECUTE THE 3838 PROGRAM 'FUSCNV' 00004360 C 00004370 CALL VPSS(IU,'EXCW',FUSCNV) 00004380 C 00004383 IF (KPRTF.LT.0) GO TO 272 00004386 C 00004390 C MOVE RESULTS INTO OUTPUT AREA C 00004400 C 00004410 CALL ARMVE(X,C,LENC) 00004420 C 00004430 C WRITE(6,5060) (X(I),I=1,8192) 00004440 C 00004450 RETURN 00004460 C 00004470 C 00004480 C ENTRY SAGAC2(A,LENA,B,LENB,C,LENC,LAG) 00004490 C ENTRY SAGAC3(A,LENA,C,LENC) WHICH IS THE SAME AS 00004500 C SAGAC2(A,LENA,A,LENA,C,LENC,LENA) 00004510 C 00004520 C ================================================================== 00004530 ENTRY SAGAC3( A,LENA,C,LENC, X,U ) 00004540 C ================================================================== 00004550 C 00004560 LENB = LENA 00004570 LAG = LENA 00004580 NTYPE = -1 00004590 GO TO 275 00004600 C 00004610 C ================================================================== 00004620 ENTRY SAGAC2( A,LENA,B,LLENB,C,LENC,LLAG, X,U ) 00004630 C ================================================================== 00004640 C 00004650 LENB = LLENB 00004660 LAG = LLAG 00004661 NTYPE = 1 00004662 C 00004670 275 ITYPE1 = 0 00004680 IF(LENB.GT.60) ITYPE1 = 1 00004690 C 00004700 IA = LENA 00004710 IB = LENB 00004720 IC = LENC 00004730 C 00004740 C CHECK IF 3838 PROGRAM HAS BEEN TRANSLATED 00004750 C 00004760 IF(IFLAG2.NE.0) GO TO 300 00004770 C 00004780 C GET A UNIT NUMBER FOR 3838 00004790 C 00004800 NWDS = 4 * 8192 + 4 00004810 CALL CSAPUN(NWDS,IU) 00004820 C 00004830 C BUILD THE 3838 PROGRAM FOR TIME DOMAIN CORRELATION 00004840 C 00004850 CALL VPSS(IU,'BLD ',ISTAT,CCW,200,CIT3,200) 00004860 C 00004870 C 00004880 CALL VPSS(IU,'XWR ',REGS,15,1) 00004890 CALL VPSS(IU,'VPUT',X,8192,0,R5) 00004900 CALL VPSS(IU,'VPUT',U,8192,0,R4) 00004910 C 00004920 C 00004930 C CLEAR OUT ELEMENTS AT BEGINNING AND END OF A 00004940 C 00004950 CALL VPSS(IU,'ZMV ',ISTATE, 00004960 * 64,0,0,1,R5) 00004970 CALL VPSS(IU,'ZMV ',ISTATE, 00004980 * 96,0,0,1,R8,R9) 00004990 C 00005000 C CONVOLVING MULTIPLY 00005010 C 00005020 CALL VPSS(IU,'CVM ',ISTATE, 00005030 * 96,0,0,1,R7,R1, 00005040 * 64,1,0,1,R10, 00005050 * 96,0,0,1,R4,R2) 00005060 C 00005070 C 00005080 CALL VPSS(IU,'VGET',X,8192,0,R7) 00005090 C 00005100 CALL VPSS(IU,'XLTE',TUSCCR) 00005110 C 00005120 C ==================================================================== 00005130 C END OF 3838 PROGRAM FOR TIME DOMAIN CORRELATION 00005140 C ==================================================================== 00005150 C 00005160 C BUILD THE 3838 PROGRAM FOR FREQUENCY DOMAIN CORRELATION 00005170 C 00005180 CALL VPSS(IU,'BLD ',ISTAT,CCW,200,CIT4,200) 00005190 C 00005200 C TRANSFER REGISTERS AND DATA TO 3838 00005210 C 00005220 CALL VPSS(IU,'XWR ',REGS,15,1) 00005230 CALL VPSS(IU,'VPUT',X,8192,0,R5) 00005240 CALL VPSS(IU,'VPUT',U,8192,0,R4) 00005250 C 00005260 C PAD ZEROES IN X AND U BUFFERS 00005270 C 00005280 CALL VPSS(IU,'ZMV ',ISTATE, 00005290 * 64,0,0,1,R5) 00005300 CALL VPSS(IU,'ZMV ',ISTATE, 00005310 * 96,0,0,1,R8,R9) 00005320 CALL VPSS(IU,'ZMV ',ISTATE, 00005330 * 96,0,0,1,R3,R12) 00005340 C 00005350 C REVERSE THE U VECTOR (FOR CORRELATION 00005360 C 00005370 CALL VPSS(IU,'REV ',ISTATE, 00005380 * 96,0,0,1,R4,R2, 00005390 * 32,0,1,R4) 00005400 C 00005410 C EXECUTE FFT ON X AND U BUFFERS 00005420 C 00005430 CALL VPSS(IU,'FFTR',ISTATE, 00005440 * 96,0,0,R13,R15, 00005450 * 64,1,0,R11) 00005460 C * 00005470 CALL VPSS(IU,'FFTR',ISTATE, 00005480 * 96,0,0,R14,R15, 00005490 * 96,0,0,R4,R11) 00005500 C 00005510 C MULTIPLY FFT OUTPUTS (COMPLEX MULTIPLY WITH COMJUGATE 00005520 C OUTPUT) 00005530 C 00005540 CALL VPSS(IU,'CMCO',ISTATE, 00005550 * 96,0,0,R13,R15, 00005560 * 32,0,R13, 00005570 * 32,0,R14) 00005580 C 00005590 C EXECUTE THE INVERSE FFT ON CONJUGATE PRODUCT 00005600 C 00005610 CALL VPSS(IU,'IFTR',ISTATE, 00005620 * 64,0,0,R11, 00005630 * 96,0,0,R13,R15) 00005640 C 00005650 C NORMALIZE OUTPUT 00005660 C 00005670 CALL VPSS(IU,'XMVX',0,1,R13,R6) 00005680 C 00005690 CALL VPSS(IU,'SMY ',ISTATE, 00005700 * 64,0,0,1,R11, 00005710 * 0,0,1, 00005720 * 32,0,R13) 00005730 C 00005740 C GET RESULTS BACK INTO 370 00005750 C 00005760 CALL VPSS(IU,'VGET',X,8192,0,R7) 00005770 C 00005780 C TRANSLATE THE 3838 PROGRAM 00005790 C 00005800 CALL VPSS(IU,'XLTE',FUSCCR) 00005810 C 00005820 C ==================================================================== 00005830 C END OF 3838 PROGRAM FREQUENCY DOMAIN CORRELATION 00005840 C ==================================================================== 00005850 C 00005860 IFLAG2 = 1 00005870 C 00005880 300 IF(ITYPE1.EQ.1) GO TO 400 00005890 C 00005900 C ==================================================================== 00005910 C PROCESS THE INPUT DATA 00005920 C TIME DOMAIN CORRELATION 00005930 C ==================================================================== 00005940 C 00005950 C CALCULATE THE ADDRESS IN BULK STORAGE FOR X 00005960 C 00005970 NDX = 1 00005980 MOVEL = LENA 00005990 C 00006000 IF(LAG.LE.0) IXADR = LENB + IABS(LAG) + 1 00006010 IF(LAG.GT.0) IXADR = LENB - LAG + 1 00006020 C 00006030 C 00006040 IF(IXADR.GT.0) GO TO 350 00006050 NDX = IABS(LENB-LAG) + 1 00006060 MOVEL = LENA - NDX + 1 00006070 IF(MOVEL.GT.0) GO TO 340 00006080 CALL ARSET(C,LENC,0.0) 00006090 RETURN 00006100 C 00006110 C 00006120 340 IXADR = 1 00006130 C 00006140 350 INDXZ = IXADR + MOVEL 00006150 LENCA = LENC + LENB - 1 00006160 IF(LENCA.LE.MOVEL) LENZ = 1 00006170 IF(LENCA.GT.MOVEL) LENZ = LENCA - MOVEL 00006180 IUADR = INDXZ + LENZ 00006190 IRET = IUADR + LENB 00006200 C 00006205 KPORIG = 0 00006210 C 00006220 360 KPRTF = KPORIG 00006225 CALL ARMVE(A(NDX),X,MOVEL) 00006230 C 00006240 IF(NTYPE.LT.0) CALL ARMVE(A,U,LENA) 00006250 IF(NTYPE.GT.0) CALL ARMVE(B,U,LENB) 00006260 C 00006270 C EXECUTE THE 3838 PROGRAM 'TUSCCR' 00006280 C 00006290 CALL VPSS(IU,'EXCW',TUSCCR) 00006300 C 00006303 IF (KPRTF.LT.0) GO TO 360 00006306 C 00006310 C MOVE RESULTS INTO OUTPUT AREA C 00006320 C 00006330 CALL ARMVE(X,C,LENC) 00006340 C 00006350 C WRITE(6,5060) (X(I),I=1,8192) 00006360 C 00006370 RETURN 00006380 C 00006390 C ==================================================================== 00006400 C PROCESS THE INPUT DATA 00006410 C ==================================================================== 00006420 C 00006430 C CALCULATE THE ADDRESS IN BULK STORAGE FOR X 00006440 C 00006450 400 NDX = 1 00006460 MOVEL = LENA 00006470 C 00006480 IF(LAG.LE.0) IXADR = LENB + IABS(LAG) + 1 00006490 IF(LAG.GT.0) IXADR = LENB - LAG + 1 00006500 C 00006510 C 00006520 IF(IXADR.GT.0) GO TO 450 00006530 NDX = IABS(LENB-LAG) + 1 00006540 MOVEL = LENA - NDX + 1 00006550 IF(MOVEL.GT.0) GO TO 440 00006560 CALL ARSET(C,LENC,0.0) 00006570 RETURN 00006580 C 00006590 C 00006600 440 IXADR = 1 00006610 C 00006620 C CALCULATE INDEX FOR ZERO PADDING 00006630 C 00006640 450 LENCA = LENC + LENB - 1 00006650 INDXZ = IXADR + MOVEL 00006660 IF(INDXZ.GT.LENCA+1) INDXZ = LENCA + 1 00006670 C 00006680 C FIND THE POWER OF 2 LARGER THAN THE LENGTH 00006690 C CALCULATED FOR A (LENCA). 00006700 C 00006710 LL = 6 00006720 L = 64 00006730 460 IF(L.GE.LENCA) GO TO 470 00006740 LL = LL + 1 00006750 L = L * 2 00006760 GO TO 460 00006770 C 00006780 C CALCULATE LENGTH FOR PADDING ZEROES IN X 00006790 C 00006800 470 LENZ = L - INDXZ + 1 00006810 C 00006820 C CALCULATE ADDRESS TO LOAD U BUFFER AND ADDRESS AND 00006830 C LENGTH FOR ZERO PADDING 00006840 C 00006850 IUADR = INDXZ + LENZ + 1 00006860 INDXZ1 = IUADR + LENB 00006870 LENZ1 = L - LENB 00006880 C 00006890 C CALCULATE POINTERS IN BULK STORAGE FOR FFT OUTPUT 00006900 C 00006910 IFFTX = IUADR + L 00006920 IFFTU = IFFTX + L + 2 00006930 LENFFT = L/2 + 1 00006940 FACT = 1.0/(4.0*L) 00006950 IRET = LENB - 1 00006960 C 00006963 KPORIG = 0 00006966 C 00006970 480 KPRTF = KPORIG 00006975 CALL ARMVE(A(NDX),X,MOVEL) 00006980 C 00006990 IF(NTYPE.LT.0) CALL ARMVE(A,U,LENA) 00007000 IF(NTYPE.GT.0) CALL ARMVE(B,U,LENB) 00007010 C 00007020 C EXECUTE THE 3838 PROGRAM 'FUSCCR' 00007030 C 00007040 CALL VPSS(IU,'EXCW',FUSCCR) 00007050 C 00007053 IF (KPRTF.LT.0) GO TO 480 00007056 C 00007060 C 00007070 C WRITE(6,5050)LENA,LENB,LENC,IA,IB,IC,IXADR,IUADR,NDX,MOVEL,INDXZ, 00007080 C * LENCA,LL,L,LENZ,INDXZ1,LENZ1,IFFTX,IFFTU,LENFFT,IRET,FACT 00007090 C 00007100 C MOVE RESULTS INTO OUTPUT AREA C 00007110 C 00007120 CALL ARMVE(X,C,LENC) 00007130 C 00007140 C WRITE(6,5060) (X(I),I=1,8192) 00007150 C 00007160 RETURN 00007170 END 00007180