CAINDMUSSEMB -- COMPUTES SEMBLANCE FUNCTION 00000030 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CTITLE USSEMB -- COMPUTES SEMBLANCE FUNCTION 00000030 CA AUTHOR PAM COOPER 00000040 CA DESIGNER PAM COOPER, JOHN MENDEKE 00000050 CA LANGUAGE S/370 FORTRAN H EXTENDED 00000060 CA WRITTEN 06-13-78 00000070 C REVISED 00000080 CA 00000090 CA 00000100 CA CALL USSEMB (SUMAR, SSQAR, DIVAR, SEMBAR, FOLD3, NOSAMP, TEMP1)00000110 CA 00000120 CA INPUT SUMAR = SUM OF AMPLITUDES ARRAY R4 00000130 CA INPUT SSQAR = SUM OF SQUARES OF AMPLITUDES ARRAY R4 00000140 CA INPUT DIVAR = ARRAY CONTAINING FOLDS R4 00000150 CA OUTPUT SEMBAR = OUTPUT OF SEMBLANCE VALUES R4 00000160 CA OUTPUT FOLD3 = MARKER OF WHERE 3 FOLD OCCURS I4 00000170 CA INPUT NOSAMP = NUMBER OF SAMPLES I4 00000180 CA IN/OUT TEMP1 = TEMPORARY WORK ARRAY R4 00000190 CA 00000200 CA 00000210 CA USSEMB COMPUTES THE SEMBLANCE VALUE FOR EACH SAMPLE, USING A 00000220 CA THREE SAMPLE WINDOW. ALSO THE POINT WHERE THE DATA BECOMES 00000230 CA THREE FOLD IS FOUND. 00000240 CA 00000250 CAEND 00000260 CTITLE USATTN -- ATTENUATES A STACKED TRACE 00000270 CA AUTHOR PAM COOPER 00000280 CA DESIGNER PAM COOPER, JOHN MENDEKE 00000290 CA LANGUAGE S/370 FORTRAN H EXTENDED 00000300 CA WRITTEN 12- -77 00000310 C REVISED MO-DA-YR 00000320 C 00000330 CA 00000340 CA 00000350 CA CALL USATTN (SEMBAR, FOLD3, OTR, NOSAMP, NAT, WINDL, TEMP1) 00000360 CA 00000370 CA INPUT SEMBAR = SEMBLANCE VALUES R4 00000380 CA INPUT FOLD3 = MARKER OF WHERE 3 FOLD OCCURS I4 00000390 CA IN/OUT OTR = STACKED TRACE R4 00000400 CA INPUT NOSAMP = NUMBER OF SAMPLES I4 00000410 CA INPUT NAT = NOISE ATTENUATION FACTOR R4 00000420 CA INPUT WINDL = WINDOW LENGTH FOR SMOOTHING I4 00000430 CA IN/OUT TEMP1 = TEMPORARY WORK ARRAY R4 00000440 CA 00000450 CA 00000460 CA USATTN USES THE SEMBLANCE VALUES TO FIND THE NOISE IN 00000470 CA OTR AND THEN ATTENUATES IT BY THE GIVEN FACTOR NAT. 00000480 CA 00000490 CA 00000500 CAEND 00000510 SUBROUTINE USSEMB (SUMAR,SSQAR,DIVAR,SEMBAR,FOLD3,NOSAMP,TEMP1) 00000520 C 00000530 IMPLICIT INTEGER (A-Z) 00000540 EXTERNAL S1ATP 00000550 C 00000560 C REAL ARRAYS IN PARAMETER LIST 00000570 C 00000580 REAL SUMAR (1) 00000590 REAL SSQAR (1) 00000600 REAL DIVAR (1) 00000610 REAL SEMBAR (1) 00000620 REAL TEMP1 (1) 00000630 REAL OTR (1) 00000640 C 00000650 C REAL VARIABLES -- LOCAL 00000660 C 00000670 REAL MINOLD 00000680 REAL MINN 00000690 REAL SUMA 00000700 REAL SUMA2 00000710 REAL NAT 00000720 REAL NT 00000730 C 00000740 CALL ARSET (SEMBAR, NOSAMP, 0.0) 00000750 CALL ARSET (TEMP1, NOSAMP, 0.0) 00000760 C 00000770 DO 10 00000780 * I = 1, NOSAMP 00000790 IF (DIVAR (I) .LT. 3) GO TO 10 00000800 FOLD3 = I 00000810 GO TO 20 00000820 10 CONTINUE 00000830 C 00000840 20 CALL ARMPF (SUMAR, SUMAR, TEMP1, NOSAMP) 00000850 NSM1 = NOSAMP - 1 00000860 C 00000870 DO 40 00000880 * K = 2, NSM1 00000890 SUMA = TEMP1(K-1) + TEMP1(K) + TEMP1(K+1) 00000900 SUMA2 = SSQAR(K-1) + SSQAR(K) + SSQAR(K+1) 00000910 NT =(DIVAR(K-1) + DIVAR(K) + DIVAR(K+1)) / 3.0 00000920 IF (NT .GE. 1.0) GO TO 30 00000930 SEMBAR(K) = 1.0 00000940 GO TO 40 00000950 C 00000960 30 IF (SUMA2*NT .EQ. 0.0) GO TO 40 00000970 SEMBAR(K) = SUMA / (SUMA2 * NT) 00000980 40 CONTINUE 00000990 C 00001000 SEMBAR(1) = SEMBAR(2) 00001010 SEMBAR(NOSAMP) = SEMBAR(NOSAMP-1) 00001020 GO TO 200 00001030 C 00001040 C 00001050 C 00001060 C 00001070 ENTRY USATTN (SEMBAR,FOLD3,OTR,NOSAMP,NAT,WINDL,TEMP1) 00001080 C 00001090 CALL ARSET (TEMP1, NOSAMP, 0.0) 00001100 HWINDL = WINDL / 2 00001110 HWLM1 = HWINDL - 1 00001120 CALL ARABM (SEMBAR, TEMP1(HWINDL), NOSAMP, WINDL) 00001130 CALL ARSET (TEMP1, HWLM1, TEMP1(HWINDL)) 00001140 CALL ARSET (TEMP1(NOSAMP-HWLM1), HWINDL, TEMP1(NOSAMP-HWINDL)) 00001150 C 00001160 C LONG WINDOW 00001170 C 00001180 NOELMT = NOSAMP - FOLD3 + 1 00001190 C 00001200 CALL ARABM (TEMP1(FOLD3), SEMBAR(FOLD3+124), NOELMT, 250) 00001210 C 00001220 C WRITE (6, 9000) 00001230 C CALL S2GRPH (TEMP1,NOSAMP,.004,.004,6) 00001240 C9000 FORMAT('1') 00001250 C 00001260 CALL ARSET (SEMBAR(1), 123+FOLD3, SEMBAR(124+FOLD3)) 00001270 CALL ARSET (SEMBAR(NOSAMP-124), 125, SEMBAR(NOSAMP-125)) 00001280 C 00001290 C WRITE (6, 9000) 00001300 C WRITE (6, 9010) (TEMP1(L) , L = 1, NOSAMP) 00001310 C9010 FORMAT (' ',10F12.7) 00001320 C 00001330 CALL ARSBF (TEMP1, SEMBAR, TEMP1, NOSAMP) 00001340 CALL ARADFC(TEMP1, TEMP1,1.0, NOSAMP) 00001350 C 00001360 DO 110 00001370 * I = 1, NOSAMP 00001380 IF (TEMP1(I) .GT. 1.0) TEMP1(I) = 1.0 00001390 110 CONTINUE 00001400 C 00001410 BEGINN = 0 00001420 ENDD = 0 00001430 MINOLD = 1.0 00001440 I = 0 00001450 C 00001460 120 I = I + 1 00001470 130 IF (I .GT. NOSAMP) GO TO 190 00001480 IF (TEMP1(I) .EQ. 1.0) GO TO 120 00001490 BEGINN = I 00001500 MINN = TEMP1(I) 00001510 C 00001520 IF (BEGINN-ENDD .GT. 3) GO TO 140 00001530 LAST = LAST * NAT / MINOLD 00001540 IF (TEMP1(ENDD) .NE. LAST) GO TO 140 00001550 C 00001560 TEMP1(ENDD+1) = TEMP1(ENDD+1) * NAT / MINOLD 00001570 TEMP1(BEGINN-1) = TEMP1(BEGINN-1) * NAT / MINOLD 00001580 C 00001590 140 DO 150 00001600 * J = BEGINN, NOSAMP 00001610 IF (TEMP1(J) .EQ. 1.0) GO TO 160 00001620 IF (TEMP1(J) .LT. MINN) MINN = TEMP1(J) 00001630 150 CONTINUE 00001640 C 00001650 J = NOSAMP + 1 00001660 160 ENDD = J - 1 00001670 IF (MINN .EQ. 0.0) MINN = 1.0 00001680 C 00001690 LAST = TEMP1(ENDD) 00001700 L = ENDD - BEGINN - 1 00001710 IF (L .LT. 5) GO TO 180 00001720 C 00001730 DO 170 00001740 * K = BEGINN, ENDD 00001750 TEMP1(K) = TEMP1(K) * NAT / MINN 00001760 170 CONTINUE 00001770 C 00001780 180 I = ENDD + 1 00001790 MINOLD = MINN 00001800 GO TO 130 00001810 C 00001820 190 TWO = 2 00001830 CALL ARABM (TEMP1,SEMBAR(TWO), NOSAMP, 3) 00001840 SEMBAR(1) = SEMBAR(TWO) 00001850 SEMBAR(NOSAMP) = SEMBAR(NOSAMP-1) 00001860 C 00001870 C WRITE (6,9000) 00001880 C WRITE (6,9010) (SEMBAR(L) , L = 1, NOSAMP) 00001890 C 00001900 C WRITE (6, 9000) 00001910 C CALL S2GRPH (SEMBAR,NOSAMP,.004,.004,6) 00001920 C 00001930 CALL ARMPF (SEMBAR, OTR, OTR, NOSAMP) 00001940 C 00001950 200 RETURN 00001960 END 00001970