CTITLE SANEVAL -- EVALUATION OF COHERENET NOISE MATRICES FOR A CDP C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA CA AUTHOR J.V.S. HARVEY CA LANGUAGE VS FORTRAN (77) FOR VECTORIZATION CA SYSTEM IBM ONLY CA REWRITTEN 30 NOV 1988 C REVISED 02-16-89 JJC FOR SPARC PRODUCTION. CA CA CA THIS SUBROUTINE COMPLETES THE CALCULATION OF COHERENT NOISE MATRICES CA CA **************************************************************** CA *** NOTE: THIS ROUTINE REPLACES SACNAX (ALL ENTRIES) *** CA **************************************************************** CA CA CA CALL SANEVAL( NUMSUM, ALIASF, CA PKCLIP, PKBALP, SPACIN, CA NUMVEL, VELMIN, VELINC, CA NUMFRQ, FRQMIN, FRQINC, CA SPECTR, HICOHR, MXCOHR, CA PEAKVF, PKBFCN, PIKVEL, CA WORKAR ) CA CA CA IN/OUT ARGUMENT TYPE DESCRIPTION CA CA IN NUMSUM I4 NUMBER OF GATHERS SUMMED CA CA IN ALIASF CH4 ALIAS FLAG CA 'ALS ' = APPLY MUTING TO ALIASED AREA CA 'NLS ' = NO MUTING TO ALIASED AREA CA CA CA IN PKCLIP I4 PICK CLIPPING LEVEL CA IN PKBALP I4 PEAK-BALANCING CUTOFF CA CA IN SPACIN R4 TRACE SPACING (REF. FOR ALIAS LINES) CA CA CA IN NUMVEL I4 NUMBER OF VELOCITY LABELS CA IN VELMIN R4 MINIMUM VELOCITY LABEL CA IN VELINC R4 VELOCITY LABEL INCREMENT CA CA CA IN NUMFRQ I4 NUMBER OF DISPLAY FREQUENCY SAMPLES CA IN FRQMIN R4 MINIMUM FREQUENCY LABEL CA IN FRQINC R4 FREQ-AXIS LABEL INCREMENT CA CA CA UPDATE SPECTR R4 F-V SPECTRA CA ( 2-D ARRAY DIMENSIONED: NUMFRQ BY NUMVEL ) CA CA OUT HICOHR R4 MAXIMUM COHERENCY FUNCTION CA ( 1-D ARRAY DIMENSIONED: NUMFRQ ) CA CA OUT MXCOHR R4 MAXIMUM COHERENCY CA CA CA OUT PEAKVF R4 VELOCITY FUNCTION FOR PEAKS CA ( 1-D ARRAY DIMENSIONED: NUMFRQ ) CA CA OUT PKBFCN R4 PEAK-BALANCING GAIN FUNCTION CA ( 1-D ARRAY DIMENSIONED: NUMFRQ ) CA CA OUT PIKVEL R4 PICKED VELOCITIES CA ( 1-D ARRAY DIMENSIONED: NUMFRQ ) CA CA CA WORK WORKAR R4 WORK AREA CA ( 2-D ARRAY DIMENSIONED: NUMFRQ BY 6 ) CA CAEND C*********************************************************************** C C SUBROUTINES CALLED: (NONE) C C*********************************************************************** C SUBROUTINE SANEVAL( NUMSUM, ALIASF, * PKCLIP, PKBALP, SPACIN, * NUMVEL, VELMIN, VELINC, * NUMFRQ, FRQMIN, FRQINC, * SPECTR, HICOHR, MXCOHR, * PEAKVF, PKBFCN, PIKVEL, * WORKAR ) IMPLICIT INTEGER (A-Z) C CHARACTER*4 ALIASF C REAL SPACIN C REAL VELMIN REAL VELINC C REAL FRQMIN REAL FRQINC C REAL SPECTR(NUMFRQ,NUMVEL) REAL HICOHR(NUMFRQ) REAL MXCOHR C REAL PEAKVF(NUMFRQ) REAL PKBFCN(NUMFRQ) REAL PIKVEL(NUMFRQ) C REAL WORKAR(NUMFRQ,6) C-------------------------------------------------------------------- C C LOCAL CONSTANT C REAL*8 PI PARAMETER ( PI = 3.14159265 ) C ------------------------------------------- C C MINIMUM RECOGNIZED AMPLITUDE FOR COHERENCE C REAL MINAMP PARAMETER ( MINAMP = 1.0E-20 ) C-------------------------------------------------------------------- C C REAL VARIABLES -- LOCAL C REAL*8 ANGLE REAL COUNT REAL CTERM REAL DF REAL FREQ REAL S REAL SCALE REAL SI REAL SJ REAL SK REAL SMIN REAL SREF REAL VEL C REAL*8 DCOS C C*********************************************************************** C*** **** C*** INITIAL PROCESSING **** C*** **** C*********************************************************************** C N = NUMFRQ C ------------------------------------------- C C SCALE SPECTRA FOR DEPTHPOINT AVERAGING C IF( NUMSUM .GT. 0 ) THEN COUNT = NUMSUM SCALE = 1.0/COUNT C DO 10 IVF = 1, NUMVEL DO 10 KF = 1, NUMFRQ SPECTR(KF,IVF) = SPECTR(KF,IVF)*SCALE 10 CONTINUE ENDIF C ------------------------------------------- C C MUTING OF THE ALIASED SPECTRUM C IF( ALIASF .EQ. 'ALS ' ) THEN VEL = VELMIN C DO 25 IVF = 1, NUMVEL FREQ = FRQMIN*SPACIN DF = FRQINC*SPACIN C DO 20 KF = 1, NUMFRQ IF( VEL .LE. FREQ ) SPECTR(KF,IVF) = 0.0 C FREQ = FREQ + DF 20 CONTINUE C VEL = VEL + VELINC 25 CONTINUE ENDIF C C*********************************************************************** C*** **** C*** FIND AMPLITUDE MAXIMA **** C*** **** C*********************************************************************** C MXCOHR = 0.0 C DO 45 KF = 1, NUMFRQ HICOHR(KF) = 0.0 PIKVEL(KF) = 0.0 PEAKVF(KF) = 0.0 45 CONTINUE C VEL = VELMIN DO 75 IVF = 1, NUMVEL DO 50 KF = 1, NUMFRQ S = SPECTR(KF,IVF) C IF( S .GT. HICOHR(KF) ) THEN HICOHR(KF) = S PIKVEL(KF) = VEL PEAKVF(KF) = VEL C IF( S .GT. MXCOHR ) MXCOHR = S ENDIF 50 CONTINUE C VEL = VEL + VELINC 75 CONTINUE C====================================================================== C C LOCATE PEAKS ABOVE MIN. AMPLITUDE C DO 125 KF = 1, NUMFRQ WORKAR(KF,1) = HICOHR(KF) 125 CONTINUE C WORKAR(1,2) = 1.0 C JF = 1 DO 140 KF = 2, NUMFRQ WORKAR(KF,2) = WORKAR(JF,1) JF = JF + 1 140 CONTINUE C JF = 1 DO 150 KF = 2, NUMFRQ WORKAR(JF,3) = WORKAR(KF,1) JF = JF + 1 150 CONTINUE C WORKAR(NUMFRQ,3) = 1.0 C DO 160 KF = 1, NUMFRQ IF( WORKAR(KF,1) .LT. WORKAR(KF,2) .OR. * WORKAR(KF,1) .LT. WORKAR(KF,3) ) * WORKAR(KF,1) = 0.0 160 CONTINUE C SMIN = 0.01*PKCLIP*MXCOHR C DO 175 KF = 1, NUMFRQ IF( WORKAR(KF,1) .LT. SMIN ) PIKVEL(KF) = 0.0 175 CONTINUE C PIKVEL(1) = 0.0 PIKVEL(N) = 0.0 C C*********************************************************************** C*** **** C*** AUTOMATIC GAIN FUNCTION **** C*** **** C*********************************************************************** C IF( PKBALP .GE. 100 ) THEN DO 210 KF = 1, NUMFRQ PKBFCN(KF) = MXCOHR 210 CONTINUE C ELSE SREF = 0.01*PKBALP*MXCOHR C IF( MXCOHR .GT. MINAMP ) THEN DO 215 KF = 1, NUMFRQ IF( WORKAR(KF,1) .LT. SREF ) WORKAR(KF,1) = 0.0 215 CONTINUE C WORKAR(1,1) = HICOHR(1) WORKAR(N,1) = HICOHR(N) C IF( SREF .GT. WORKAR(1,1) ) WORKAR(1,1) = SREF IF( SREF .GT. WORKAR(N,1) ) WORKAR(N,1) = SREF C====================================================================== C C MULTI-PASS FUNCTION DETERMINATION C PFLAG = 1 DO 280 PASS = 1, 5 IF( PFLAG .EQ. 1 ) THEN PFLAG = 0 C ------------------------------------------- C C SELECT REFERENCE PEAKS AND DETERMINE INTERPOLATION PARM. C SI = 0.0 IS = 0 C DO 225 KF = 1, NUMFRQ SK = WORKAR(KF,1) C IF( SK .GE. SREF ) THEN WORKAR(KF,2) = SK WORKAR(KF,3) = 0.0 WORKAR(KF,4) = 0.0 C IF( IS .GT. 0 ) THEN II = IS + 1 KK = KF - 1 C IF( KK .GE. II ) THEN COUNT = 1.0*( KF - IS ) C DO 220 JF = II, KK WORKAR(JF,2) = SI WORKAR(JF,3) = SK WORKAR(JF,4) = ( JF - IS )/COUNT 220 CONTINUE ENDIF ENDIF C IS = KF SI = SK ENDIF 225 CONTINUE C ------------------------------------------- C C INITIAL COSINE TAPER BETWEEN PEAKS C DO 240 KF = 1, NUMFRQ WORKAR(KF,5) = 1.0 WORKAR(KF,6) = 1.0 240 CONTINUE C DO 250 KF = 1, NUMFRQ SI = WORKAR(KF,2) SK = WORKAR(KF,3) ANGLE = PI*WORKAR(KF,4) C CTERM = 1.0 - DCOS( ANGLE ) C SJ = SI + 0.5*( SK - SI )*CTERM C IF( SJ .GE. HICOHR(KF) ) THEN WORKAR(KF,5) = CTERM WORKAR(KF,6) = 0.0 ENDIF 250 CONTINUE C ------------------------------------------- C C CHECK FOR OVER-SATURATION C SI = 0.0 IS = 0 C DO 275 KF = 1, NUMFRQ SK = WORKAR(KF,1) C IF( SK .GE. SREF ) THEN KK = KF - 1 C IF( IS .GE. 1 ) THEN II = IS + 1 C IK = ( IS + KF )/2 KI = IK + 1 C IF( II .LT. KK ) THEN COUNT = 1.0*( KF - IS ) C IF( SI .GT. SK ) THEN FLAG = 0 DO 260 JF = II, IK IF( WORKAR(JF,6) .EQ. 1.0 ) * FLAG = 1 260 CONTINUE C IF( FLAG .EQ. 1 ) THEN PFLAG = 1 WORKAR(II,1) = SI ENDIF C ELSE IF( SI .LT. SK ) THEN FLAG = 0 DO 270 JF = KI, KK IF( WORKAR(JF,6) .EQ. 1.0 ) * FLAG = 1 270 CONTINUE C IF( FLAG .EQ. 1 ) THEN PFLAG = 1 WORKAR(KK,1) = SK ENDIF ENDIF ENDIF ENDIF C IS = KF SI = SK ENDIF 275 CONTINUE ENDIF 280 CONTINUE C====================================================================== C C INTERPOLATE BETWEEN PEAKS C DO 290 KF = 1, NUMFRQ SI = WORKAR(KF,2) SK = WORKAR(KF,3) C CTERM = WORKAR(KF,5) C PKBFCN(KF) = SI + 0.5*( SK - SI )*CTERM 290 CONTINUE ENDIF ENDIF RETURN END