CTITLE SARAPPL -- MULTI-LAYER LONG WAVELENGTH STATIC CORRECTION APPLICATION C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA CA DESIGNER J. V. S. HARVEY CA LANGUAGE VS FORTRAN (77) CA REWRITTEN 17 MAY 1988 C REVISED 12-14-89 JJC CHANGED THAR67 TO THVSVT FOR C PSEUDO DATUM ELEVATION. CA CA CA THIS SUBROUTINE APPLIES STATIC SHIFT TO TRACES AND UPDATES CA THEIR TRACE HEADERS ACCORDINGLY. CA CA CA CALL SARAPPL( IPR, KPBUGF, NUMHRZ, CA LINE, DXGRID, SFLAG, XMIN, XMAX, CA THL, THNS, SIMS, COEF, CA DATUMF, REPVEL, PSEUDO, CA NCDPN, CMODEL, CDPNID, CDPNUM, CA NCDPT, CDPREF, CA NSHOT, SMODEL, SHOTID, SHOTNO, SRESID, CA LCTPSP, CSPREF, STATIC, CA NRECV, RMODEL, RECVID, RRESID, CA NGRID, ZMODEL, PMODEL, CA INH, INTR, STWORK, OH, OTR ) CA CA CA IN/OUT ARGUMENT TYPE DESCRIPTION CA CA IN IPR I4 DEBUG OUTPUT UNIT NUMBER CA IN KPBUGF I4 DEBUG FLAG CA (AT LEAST 2 FOR PRINTOUT OF RESULTS) CA IN NUMHRZ I4 NUMBER OF HORIZONS CA CA CA IN LINE R4 UNIT VECTOR REPRESENTING LINE BEARING CA ( ARRAY LENGTH 2: (X,Y) ) CA IN DXGRID R4 ANALYSIS GRID SPACING CA CA IN SFLAG I4 CDP TRACE SORTING CONVENTION CA -1 FOR NEGATIVE OFFSETS ON SIDE 1 CA +1 POSITIVE OFFSETS ON SIDE 1 CA CA IN XMIN R4 MINIMUM IN-LINE X COORDINATE CA IN XMAX R4 MAXIMUM IN-LINE X COORDINATE CA CA CA IN THL I4 TRACE HEADER LENGTH (WORDS) CA IN THNS I4 TRACE RECORD LENGTH (WORDS) CA IN SIMS R4 TRACE SAMPLING INTERVAL (MS) CA IN COEF R4 COEFFICIENTS FOR TRACE INTERPOLATION CA ( 2-D ARRAY DIMENSIONED: 12 BY 0:100 ) CA CA IN DATUMF CH4 STATICS APPLICATION (DATUM) TYPE CA 'USER' FOR USER-DEFINED DATUM CA 'FCDP' FLOATING CDP DATUM CA 'MINS' AVG. FLOATING CDP DATUM CA 'MIGD' MIGRATION DATUM CA 'REFL' REFERENCE REFLECTOR FOCUSING CA 'FLAT' REFERENCE REFLECTOR FLATTENING CA CA IN REPVEL R4 REPLACEMENT VELOCITY FOR STATICS APPLICATION CA IN PSEUDO R4 PSEUDO-DATUM CA CA CA IN NCDPN I4 NUMBER OF CDP LOCATIONS CA IN CMODEL R8 MODEL VALUES ASSOCIATED WITH CDP LOCATIONS CA (CDPN,1) = VERTICAL RAY TIME (SEC) CA (CDPN,2) = DATUM ELEVATION CA (CDPN,3) = STATIC REFERENCE TIME CA (CDPN,4) = "FLAT" VERTICAL RAY TIME (SEC) CA ( 2-D ARRAY DIMENSIONED: NCDPN BY 4 ) CA CA IN CDPNID R4 CDP IDENTIFICATION ARRAY CA (1,I) = X COORDINATE (IN-LINE) CA IN UNITS OF GRID-POINT POSITION CA (2,I) = SURFACE ELEVATION CA IN ORIGINAL UNITS CA ( 2-D ARRAY DIMENSIONED: 2 BY NCDPN ) CA IN CDPNUM I2 CDP IDENTIFICATION ARRAY CA ( 1-D ARRAY DIMENSIONED: NCDPN ) CA CA CA IN NCDPT I4 MAX. NUMBER OF TRACES PER CDPN SIDE CA IN CDPREF I2 CDP-TO-SHOT CROSS-REFERENCE INDICES CA (1,SIDE,CDPT,CDPN) = SHOT INDEX CA (2,SIDE,CDPT,CDPN) = RECEIVER INDEX CA (3,SIDE,CDPT,CDPN) = ORTN (TRACE) CA ( 4-D ARRAY DIMENSIONED: 3 BY 2 BY NCDPT BY NCDPN ) CA CA CA IN NSHOT I4 NUMBER OF SHOTPOINTS PICKED CA IN SMODEL R8 SHOT-CONSISTENT OVERBURDEN VALUES CA (SHOT) = VERTICAL RAY TIMES CA ( 1-D ARRAY DIMENSIONED: NSHOT ) CA CA IN SHOTID R4 SHOTPOINT IDENTIFICATION ARRAY CA (1,I) = X COORDINATE (IN-LINE) CA IN UNITS OF GRID-POINT POSITION CA (2,I) = Y COORDINATE (CROSS-LINE) CA IN UNITS OF GRID-POINT POSITION CA (3,I) = SURFACE ELEVATION CA IN ORIGINAL UNITS CA (4,I) = RECIPROCAL RECEIVER NUMBER CA AS INDEX PLUS FRAC. DISTANCE CA (5,I) = EQUIVALENT CDPN LOCATION CA AS INDEX PLUS FRAC. DISTANCE CA ( 2-D ARRAY DIMENSIONED: 5 BY NSHOT ) CA IN SHOTNO I2 PICKED SHOTPOINT NUMBER LIST CA ( 1-D ARRAY DIMENSIONED: NSHOT ) CA CA IN SRESID R4 SHOT-CONSISTENT LEAST-SQUARES RESIDUALS CA (SHOT,1) = POSITIVE RAY (L-R) RESIDUAL CA (SHOT,2) = NEGATIVE RAY (R-L) RESIDUAL CA ( 2-D ARRAY DIMENSIONED: NSHOT BY 2 ) CA CA CA IN LCTPSP I4 NUMBER OF TRACES PER SHOT CA IN CSPREF I2 SHOT-TO-CDP CROSS-REFERENCE INDICES CA (1,ORTN,SHOT) = CDPN CA (2,ORTN,SHOT) = CDPT (NEG FOR LOW SIDE) CA ( 3-D ARRAY DIMENSIONED: 3 BY LCTPSP BY NSHOT ) CA CA IN STATIC R4 MODEL-PREDICTED RAYPATH STATIC SHIFT IN SEC CA *** DEFAULTS TO 1.0E+10 FOR NO ESTIMATE *** CA ( 2-D ARRAY DIMENSIONED: LCTPSP BY NSHOT ) CA CA CA IN NRECV I4 NUMBER OF RECEIVERS CA IN RMODEL R8 RECV-CONSISTENT OVERBURDEN VALUES CA (RECV) = VERTICAL RAY TIMES CA ( 1-D ARRAY DIMENSIONED: NRECV ) CA CA IN RECVID R4 RECEIVER IDENTIFICATION ARRAY CA (1,I) = X COORDINATE (IN-LINE) CA IN UNITS OF GRID-POINT POSITION CA (2,I) = Y COORDINATE (CROSS-LINE) CA IN UNITS OF GRID-POINT POSITION CA (3,I) = SURFACE ELEVATION CA IN ORIGINAL UNITS CA (4,I) = RECIPROCAL SHOT LOCATION NUMBER CA AS INDEX PLUS FRAC. DISTANCE CA (5,I) = EQUIVALENT CDPN LOCATION CA AS INDEX PLUS FRAC. DISTANCE CA ( 2-D ARRAY DIMENSIONED: 5 BY NRECV ) CA CA IN RRESID R4 RECV-CONSISTENT OVERBURDEN VALUES CA (RECV,1) = POSITIVE RAY (L-R) RESIDUAL CA (RECV,2) = NEGATIVE RAY (R-L) RESIDUAL CA ( 2-D ARRAY DIMENSIONED: NRECV BY 2 ) CA CA CA IN NGRID I4 NUMBER OF ANALYSIS GRID POINTS CA IN ZMODEL R4 THE ELEVATION MODEL FOR ALL HORIZONS CA -- INITIALLY DEFAULTED TO SURFACE VALUES CA ( 2-D ARRAY DIMENSIONED: NGRID BY 0:NUMHRZ ) CA CA IN PMODEL R4 THE SLOWNESS MODEL FOR THE LAYER BELOW CA EACH HORIZON DEFINED FOR ZMODEL CA (GRID,CURHRZ,1) = SLOWNESS ESTIMATE CA (GRID,CURHRZ,1) = VELOCITY RMS ERROR CA -- INITIALLY DEFAULTED TO SURFACE VALUES CA ( 3-D ARRAY DIMENSIONED: NGRID BY 0:NUMHRZ BY 2 ) CA CA CA IN INH I4 INPUT SEISMIC TRACE HEADER CA ( 1-D ARRAY DIMENSIONED: THL ) CA IN INTR R4 INPUT SEISMIC TRACE CA ( 1-D ARRAY DIMENSIONED: THNS ) CA CA WORK STWORK R4 STATIC APPLICATION WORK AREA CA ( 2-D ARRAY DIMENSIONED: THNS BY 3 ) CA CA OUT OH I4 OUTPUT SEISMIC TRACE HEADER CA ( 1-D ARRAY DIMENSIONED: THL ) CA OUT OTR R4 OUTPUT SEISMIC TRACE CA ( 1-D ARRAY DIMENSIONED: THNS ) CA CA********************************************************************** CA** **** CA** NOTE: THE FOLLOWING EVALUATIONS GIVE STATIC SHIFTS **** CA** **** CA** SHOT SHIFT = CMODEL(CDPN,3) - SMODEL(SHOT) **** CA** RECV SHIFT = CMODEL(CDPN,3) - RMODEL(RECV) **** CA** **** CA********************************************************************** CA CA PERTINENT TRACE HEADER ENTRIES CA CA IN/OUT ARGUMENT TYPE DESCRIPTION CA CA IN/OUT THTICD I4 TRACE IDENTIFICATION CODE CA CA IN THSSP I4 SHOTPOINT NUMBER CA IN THORTN I4 TRACE NUMBER CA IN THCDPN I4 CDP NUMBER CA CA IN THSRXC I4 SOURCE X COORDINATE CA IN THSRYC I4 SOURCE Y COORDINATE CA CA IN THDPXC I4 DEPTH POINT X COORDINATE CA IN THDPYC I4 DEPTH POINT Y COORDINATE CA CA IN THRXC I4 RECEIVER X COORDINATE CA IN THRYC I4 RECEIVER Y COORDINATE CA CA IN THSDPT I4 SOURCE DEPTH BELOW SURFACE CA CA IN/OUT THSTUH I4 SOURCE UPHOLE TIME (RESET TO 0 IF -9999) CA IN/OUT THRTUH I4 RECEIVER UPHOLE TIME (RESET TO 0 IF -9999) CA CA IN/OUT THFTST R4 FLOATING TOTAL STATIC APPLIED (MS) CA CA IN/OUT THFRDS R4 FLOATING RESIDUAL DEPTH-POINT STATIC CA OUT THFRMS R4 FLOATING RESIDUAL MOVE-OUT STATIC CA OUT THFRRS R4 FLOATING RESIDUAL RECEIVER STATIC CA OUT THFRSS R4 FLOATING RESIDUAL SHOT STATIC CA OUT THFRSC R4 FLOATING RESIDUAL STATIC CORRECTION CA CA OUT THSST I4 SOURCE STATIC CORRECTION (MS) CA OUT THRST I4 RECEIVER STATIC CORRECTION (MS) CA CA OUT THSMDE I4 STAT COMPUTED MEAN DEPTH-POINT DATUM ELEVATION CA OUT THDPDE I4 DEPTH-POINT DATUM ELEVATION CA OUT THDELS I4 DATUM ELEVATION AT SOURCE CA OUT THDELR I4 DATUM ELEVATION AT RECEIVER CA CA OUT THEREF I4 ELEVATION OF REFERENCE REFRACTOR CJJ OUT THVSVT I4 PSEUDO-DATUM ELEVATION (BORROW VSP HEADER) CA OUT THWV I4 WEATHERING VELOCITY CA OUT THSWV I4 SUBWEATHERING VELOCITY CA CA OUT THFLV I4 FIRST LIVE VALUE IN TRACE CA C====================================================================== C C SUBROUTINES CALLED: USRTHV -- READ TRACE HEADER VALUE C USSTHV -- STORE TRACE HEADER VALUE C C ARMVE -- ARRAY BLOCK COPY C C*********************************************************************** C SUBROUTINE SARAPPL( IPR, KPBUGF, NUMHRZ, * LINE, DXGRID, SFLAG, XMIN, XMAX, * THL, THNS, SIMS, COEF, * DATUMF, REPVEL, PSEUDO, * NCDPN, CMODEL, CDPNID, CDPNUM, * NCDPT, CDPREF, * NSHOT, SMODEL, SHOTID, SHOTNO, SRESID, * LCTPSP, CSPREF, STATIC, * NRECV, RMODEL, RECVID, RRESID, * NGRID, ZMODEL, PMODEL, * INH, INTR, STWORK, OH, OTR ) IMPLICIT INTEGER (A-Z) C PARAMETER ( NINES = -9999 ) C REAL LINE(2) REAL DXGRID REAL XMIN REAL XMAX C REAL SIMS REAL COEF(12,0:100) C CHARACTER*4 DATUMF REAL REPVEL REAL PSEUDO C REAL*8 CMODEL(NCDPN,4) REAL CDPNID(2,NCDPN) INTEGER*2 CDPNUM(NCDPN) C INTEGER*2 CDPREF(3,2,NCDPT,NCDPN) C REAL*8 SMODEL(NSHOT) REAL SHOTID(5,NSHOT) INTEGER*2 SHOTNO(NSHOT) REAL SRESID(NSHOT,2) C INTEGER*2 CSPREF(2,LCTPSP,NSHOT) REAL STATIC(LCTPSP,NSHOT) C REAL*8 RMODEL(NRECV) REAL RECVID(5,NRECV) REAL RRESID(NRECV,2) C REAL ZMODEL(NGRID,0:NUMHRZ) REAL PMODEL(NGRID,0:NUMHRZ,2) C INTEGER INH(THL) REAL INTR(THNS) C REAL STWORK(THNS,3) C INTEGER OH(THL) REAL OTR(THNS) C---------------------------------------------------------------------- C C REAL VARIABLES -- LOCAL C REAL DX1, DX2 REAL P, P1, P2 C REAL FRDS REAL FTST REAL RSTAT REAL SSTAT REAL TSTAT REAL SSHIFT C REAL RSHIFT REAL WEIGHT C REAL X, XC, XS, XR C---------------------------------------------------------------------- C C CHARACTER STRINGS -- LOCAL C CHARACTER*4 NOCODE /' '/ CHARACTER*4 CODES C C*********************************************************************** C*** **** C*** TRACE HEADER MANIPULATIONS **** C*** **** C*********************************************************************** C CODES = NOCODE C C COPY ORIGINAL TRACE HEADER C CALL ARMVE( INH, OH, THL ) C====================================================================== C C LOCATE SHOTPOINT C CALL USRTHV( INH, 'THSSP ', SSP ) C SHOT = 0 DO 10 SHOT1 = 1, NSHOT JSHOT = SHOTNO(SHOT1) IF( SSP .EQ. JSHOT ) SHOT = SHOT1 10 CONTINUE C IF( SHOT .EQ. 0 ) THEN CODES(2:2) = 'S' C CALL USRTHV( INH, 'THSRXC ', IX ) CALL USRTHV( INH, 'THSRYC ', IY ) X = IX*LINE(1) + IY*LINE(2) C IF( SFLAG .LT. 0 ) THEN DX1 = ( X - XMIN ) ELSE DX1 = ( XMAX - X ) ENDIF XS = 1.0 + ( DX1/DXGRID ) C SHOT = 1 C SHOT1 = 1 DO 15 SHOT2 = 2, NSHOT X = 0.5*( SHOTID(1,SHOT1) + SHOTID(1,SHOT2) ) SHOT1 = SHOT2 C IF( XS .GT. X ) SHOT = SHOT2 15 CONTINUE ENDIF C ------------------------------------------- C C LOCATE CDP C CALL USRTHV( INH, 'THCDPN ', CDPN ) C CDPI = 0 DO 20 CDP1 = 1, NCDPN CDPL = CDPNUM(CDP1) IF( CDPN .EQ. CDPL ) CDPI = CDP1 20 CONTINUE C IF( CDPI .EQ. 0 ) THEN CODES(3:3) = 'C' C CALL USRTHV( INH, 'THDPXC ', IX ) CALL USRTHV( INH, 'THDPYC ', IY ) X = IX*LINE(1) + IY*LINE(2) C IF( SFLAG .LT. 0 ) THEN DX1 = ( X - XMIN ) ELSE DX1 = ( XMAX - X ) ENDIF XC = 1.0 + ( DX1/DXGRID ) C CDPI = 1 C CDP1 = 1 DO 25 CDP2 = 2, NCDPN X = 0.5*( CDPNID(1,CDP1) + CDPNID(1,CDP2) ) CDP1 = CDP2 C IF( XC .GT. X ) CDPI = CDP2 25 CONTINUE ENDIF C ------------------------------------------- C C LOCATE RECEIVER C CALL USRTHV( INH, 'THORTN ', ORTN ) C IF( ORTN .GT. 0 .AND. SHOT .GT. 0 .AND. CDPI .GT. 0 ) THEN CDPT = CSPREF(2,ORTN,SHOT) C IF( CDPT .GT. 0 ) THEN RECV = CDPREF(2,2,CDPT,CDPI) ELSE IF( CDPT .LT. 0 ) THEN J = 0 - CDPT RECV = CDPREF(2,1,J,CDPI) ELSE RECV = 0 ENDIF ELSE RECV = 0 CDPT = 0 ENDIF C IF( RECV .EQ. 0 ) THEN CODES(4:4) = 'R' C CALL USRTHV( INH, 'THRXC ', IX ) CALL USRTHV( INH, 'THRYC ', IY ) X = IX*LINE(1) + IY*LINE(2) C IF( SFLAG .LT. 0 ) THEN DX1 = ( X - XMIN ) ELSE DX1 = ( XMAX - X ) ENDIF XR = 1.0 + ( DX1/DXGRID ) C RECV = 1 C RECV1 = 1 DO 30 RECV2 = 2, NRECV X = 0.5*( RECVID(1,RECV1) + RECVID(1,RECV2) ) RECV1 = RECV2 C IF( XR .GT. X ) RECV = RECV2 30 CONTINUE ENDIF C---------------------------------------------------------------------- C C RETREIVE PERTINENT TRACE-HEADER PARAMETERS C CALL USRTHV( INH, 'THTICD ', TICD ) CALL USRTHV( INH, 'THFLV ', THFLV ) C ------------------------------------------- C C PREVIOUS STATIC APPLICATION VALUES C IF( TICD .EQ. 1 .OR. TICD .EQ. 2 ) THEN CALL USRTHV( INH, 'THFRDS ', FRDS ) CALL USRTHV( INH, 'THFTST ', FTST ) CALL USRTHV( INH, 'THSDPT ', SDPT ) C CALL USRTHV( INH, 'THSTUH ', STUH ) IF( STUH .EQ. NINES ) STUH = 0 CALL USSTHV( OH, 'THSTUH ', STUH ) C CALL USRTHV( INH, 'THRTUH ', RTUH ) IF( RTUH .EQ. NINES ) RTUH = 0 CALL USSTHV( OH, 'THRTUH ', RTUH ) C---------------------------------------------------------------------- C C DATUM ELEVATIONS C DPDE = CMODEL(CDPI,2) + 0.5 SMDE = DPDE DELR = DPDE DELS = DPDE C ------------------------------------------- C C DATUM ELEVATION AT CDP C CALL USSTHV( OH, 'THDPDE ', DPDE ) CALL USSTHV( OH, 'THSMDE ', SMDE ) C ------------------------------------------- C C DATUM ELEVATION AT RECV C CALL USSTHV( OH, 'THDELR ', DELR ) C ------------------------------------------- C C DATUM ELEVATION AT SHOT C CALL USSTHV( OH, 'THDELS ', DELS ) C---------------------------------------------------------------------- C C SOURCE STATIC C SSTAT = CMODEL(CDPI,3) - SMODEL(SHOT) C IF( SHOTID(1,SHOT) .LT. RECVID(1,RECV) ) THEN SSTAT = SSTAT - SRESID(SHOT,1) ELSE SSTAT = SSTAT - SRESID(SHOT,2) ENDIF C IF( SSTAT .GT. 0.0 ) SST = SSTAT*1000.0 + 0.5 IF( SSTAT .LE. 0.0 ) SST = SSTAT*1000.0 - 0.5 CALL USSTHV( OH, 'THSST ', SST ) C ------------------------------------------- C C RECEIVER GROUP STATIC C RSTAT = CMODEL(CDPI,3) - RMODEL(RECV) C IF( SHOTID(1,SHOT) .LT. RECVID(1,RECV) ) THEN RSTAT = RSTAT - RRESID(RECV,2) ELSE RSTAT = RSTAT - RRESID(RECV,1) ENDIF C IF( RSTAT .GT. 0.0 ) RST = RSTAT*1000.0 + 0.5 IF( RSTAT .LE. 0.0 ) RST = RSTAT*1000.0 - 0.5 CALL USSTHV( OH, 'THRST ', RST ) C ------------------------------------------- C C TOTAL STATIC C IF( DATUMF .EQ. 'REFL' .OR. DATUMF .EQ. 'FLAT' ) THEN TSTAT = 1000.0*STATIC(ORTN,SHOT) C ELSE TSTAT = 1000.0*( SSTAT + RSTAT ) ENDIF C CALL USSTHV( OH, 'THFTST ', TSTAT ) C SSHIFT = TSTAT - FTST + STUH C ------------------------------------------- C C RESET THE RESIDUAL STATICS TO ZERO C CALL USSTHV( OH, 'THFRDS ', 0.0 ) CALL USSTHV( OH, 'THFRMS ', 0.0 ) CALL USSTHV( OH, 'THFRRS ', 0.0 ) CALL USSTHV( OH, 'THFRSC ', 0.0 ) CALL USSTHV( OH, 'THFRSS ', 0.0 ) C---------------------------------------------------------------------- C C MODEL VALUES C IF( CDPNID(1,CDPI) .LE. 1.0 ) THEN V1 = 1.0/PMODEL(1,0,1) ZN = ZMODEL(1,NUMHRZ) C ELSE IF( CDPNID(1,CDPI) .GE. 1.0*NGRID ) THEN V1 = 1.0/PMODEL(NGRID,0,1) ZN = ZMODEL(NGRID,NUMHRZ) C ELSE GRIDL = 1 DO 150 GRIDR = 2, NGRID DX1 = CDPNID(1,CDPI) - 1.0*GRIDL DX2 = GRIDR*1.0 - CDPNID(1,CDPI) C IF( 0.0 .LT. DX1 .AND. DX1 .LT. 1.0 ) THEN P1 = PMODEL(GRIDL,0,1) P2 = PMODEL(GRIDR,0,1) P = P1*DX2 + P2*DX1 V1 = 1.0/P C ZN = ZMODEL(GRIDL,NUMHRZ)*DX2 * + ZMODEL(GRIDR,NUMHRZ)*DX1 ENDIF C GRIDL = GRIDR 150 CONTINUE ENDIF C ------------------------------------------- C C WEATHERING AND REPLACEMENT VELOCITIES. C CALL USSTHV( OH, 'THWV ', V1 ) C VR = REPVEL + 0.5 CALL USSTHV( OH, 'THSWV ', VR ) C ------------------------------------------- C C PSEUDO-DATUM ELEVATION C IZ = PSEUDO + 0.5 CALL USSTHV( OH, 'THVSVT ', IZ ) C ------------------------------------------- C C REFRACTOR ELEVATION (AT CDP) C CALL USSTHV( OH, 'THEREF ', ZN ) C C*********************************************************************** C*** **** C*** STATIC SHIFT APPLICATION **** C*** **** C*********************************************************************** C IF( TICD .EQ. 1 .AND. SSHIFT .NE. 0.0 ) THEN RSHIFT = SSHIFT/SIMS ISHIFT = RSHIFT IF( RSHIFT .LT. 0 ) ISHIFT = ISHIFT - 1 C HSHIFT = THNS/2 LSHIFT = 0 - HSHIFT C IF( ISHIFT .GT. HSHIFT ) THEN CODES(1:1) = 'H' ISHIFT = HSHIFT IFRAC = 0 ELSE IF( ISHIFT .LT. LSHIFT ) THEN CODES(1:1) = 'L' ISHIFT = LSHIFT IFRAC = 0 ELSE IFRAC = 100.0*( RSHIFT - ISHIFT ) + 0.5 IF( IFRAC .LT. 0 ) IFRAC = 0 IF( IFRAC .GT. 100 ) IFRAC = 100 ENDIF C DO 225 K = 1, THNS OTR(K) = 0.0 225 CONTINUE C DO 275 I = 1, 12 DO 240 K = 1, THNS STWORK(K,1) = 0.0 STWORK(K,2) = 0.0 STWORK(K,3) = 0.0 240 CONTINUE C WEIGHT = COEF(I,IFRAC) C KS = ISHIFT + I - 6 DO 250 K = 1, THNS KS = KS + 1 C STWORK(KS,2) = WEIGHT*INTR(K) 250 CONTINUE C DO 270 K = 1, THNS OTR(K) = OTR(K) + STWORK(K,2) 270 CONTINUE 275 CONTINUE C ------------------------------------------- C C UPDATE FIRST LIVE VALUE AND KILLED TRACE FLAG C FLV = 0 DO 350 I = 1, THNS IF( FLV .EQ. 0 .AND. OTR(I) .NE. 0.0 ) FLV = I 350 CONTINUE CALL USSTHV( OH, 'THFLV ', FLV ) C IF( FLV .EQ. 0 ) THEN TID = 2 CALL USSTHV( OH, 'THTICD ', 2 ) ELSE TID = TICD ENDIF C====================================================================== C C COPY ORIGINAL TRACE IF NO STATIC CORRECTIONS C ELSE CALL ARMVE( INTR, OTR, THNS ) C FLV = THFLV TID = TICD C RSHIFT = 0 ISHIFT = 0 IFRAC = 0 ENDIF C C*********************************************************************** C*** **** C*** DIAGNOSTIC PRINT OF STATICS CORRECTIONS **** C*** **** C*********************************************************************** C IF( KPBUGF .GE. 2 ) * WRITE( IPR, 8002 ) SSP, RECV, ORTN, CDPN, CDPT, * STUH, SDPT, * THFLV, TICD, FTST, * SST, RST, TSTAT, * FLV, TID, SSHIFT, * ISHIFT, IFRAC, RSHIFT, CODES ELSE WRITE( IPR, 8001 ) SSP, RECV, ORTN, CDPN, CDPT, TICD C CALL ARMVE( INTR, OTR, THNS ) ENDIF RETURN C C*********************************************************************** C*** **** C*** FORMAT STATEMENTS **** C*** **** C*********************************************************************** C 8001 FORMAT(5I5,' *** INVALID TICD VALUE: ',I5) 8002 FORMAT(5I5,2I7,4(2I6,F8.3),1X,A4) END