CTITLESAAVEL - STEERING ROUTINE FOR COMBINED AVO/VELOCITY ANALYSIS 00010005 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** C 00020005 CA AUTHOR H. W. SWAN 00030005 CA DESIGNER H. W. SWAN 00040005 CA SYSTEMS IBM / CRAY 00050005 CA LANGUAGE VS FORTRAN VERSION 2.2 / CRAY CFT 00060005 CA WRITTEN 12-03-87 00070005 CA LAST REVISED 03-16-90 00080007 C REVISED 05-24-91 JJC - ADDED PARAMETER TO FOISSD CALL. 00090030 C - CHANGED IMPLICIT NONE TO (A-Z). 00100030 C REVISED 12-17-91 JJC - MODIFIED TO MEET SPARC STANDARDS. 00110032 C 00120005 C *** NOTE TO WOULD-BE REVISIONISTS: 00130005 C IF YOU MAKE A CHANGE, PLEASE UPDATE THE DATE OF THIS 00140005 C CHANGE. DO A "FIND 'DATA VERSION' " TO LOCATE 00150005 C THE LINE OF CODE TO CHANGE. 00160005 C 00170005 C REVISED BY MM-DD-YY REASON 00180005 C --- -------- --------------------------------------00190005 C HWS 04-20-88 CHANGED 'COFGEN' TO 'MCOFGN'. 00200005 C HWS 04-26-88 CHANGED 'SCOND' TO 'MACONV'. 00210005 C HWS 06-13-88 ADDED PHASE ROTATION CAPABILITY. 00220005 C HWS 06-15-88 ACCEPT ALL VELOCITY TRACES, 00230005 C NOT JUST THE 1RST FOR THE CDP GATHER. 00240005 C IF MULTIPLE "NMO VFU'S" ARE APPLIED, 00250005 C ONLY THE LAST ONE WILL TAKE EFFECT. 00260005 C HWS 07-06-88 ADDED OPTION 'T' FOR TAU-P CAPABILITY.00270005 C HWS 07-11-88 ADDED WORK ARRAY FOR FULLY VECTORIZED 00280005 C VERSION OF NMO CORRECTION. 00290005 C HWS 07-13-88 FOR OPTION 'Q', PRINT THE CDP NUMBER 00300005 C HAVING THE LARGEST ABSOLUTE ATTRIBUTE.00310005 C HWS 10-10-88 ADDED DIP CORRECTION FOR TAU-P DATA. 00320005 C HWS 10-26-88 ADDED LIMITATION ON % OF APERTURE. 00330005 C INCORPORATE LAST LIVE DATA VALUE. 00340005 C DEBUG PRINT FLAG COMES FROM KPBUGF. 00350005 C HWS 11-15-88 FIXED BUG IN THE CALL TO 'FOIDSD': 00360005 C (2ND ARG = RECORD LENGTH). 00370005 C HWS 12-15-88 GUARD AGAINST INDEX OF FIRST LIVE 00380005 C VALUE BEING ZERO OR NEGATIVE. 00390005 C HWS 12-20-88 ENABLE INVERSION FILTERS TO SPAN 00400005 C MORE THAN ONE SEISPARM RECORD 00410005 C HWS 01-12-89 ELIMINATE SVC 99 CHECK OF WORK 00420005 C FILES ALREADY IN USE. 00430005 C HWS 05-17-89 IF 'THOT' = 0 , AND WE'RE IN 00440005 C TAU-P MODE, IGNORE 'THFLV'. 00450005 C HWS 08-03-89 ALLOCATED UNRESERVED COMMON FOR 00460005 C 'SAHCIC' SCRATCH ARRAY 00470005 C HWS 08-04-89 IMPROVED ACCURACY FOR OPTION 'I'. 00480005 C HWS 11-21-89 ADDED ROTATION IN THE A-B PLANE. 00490005 C HWS 03-24-90 ADDED ABILITY TO PERFORM 'QULR' 00500026 C ATTRIBUTE SCALING BASED ON 00510007 C HISTOGRAMS, UNLESS OPTION 'Z' 00520007 C IS SPECIFIED. 00530007 C HWS 03-28-90 PROCESS NOW REALLY DOES ABANDON 00540028 C IF NO CDP HAS A VELOCITY FUNCTION. 00550028 CA 00560005 CA CALLING SEQUENCE: 00570005 CA CALL SAAVEL(INH, INTR, OH, OTR, NS, THL, ICOM, XCOM, SIZCOM) 00580005 CA 00590005 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00600005 CA ------ -------- ---- ----------- 00610005 CA 00620005 CA IN INH (I4) THE INPUT HEADER 00630005 CA IN INTR (R4) THE INPUT TRACE 00640005 CA OUT OH (I4) THE OUTPUT HEADER 00650005 CA OUT OTR (R4) THE OUTPUT TRACE 00660005 CA IN NS I4 THE LENGTH OF THE 'INTR' AND 'OTR' 00670005 CA ARRAYS 00680005 CA IN THL I4 THE LENGTH OF THE 'INH' AND 'OH' ARRAYS 00690005 CA IN/OUT ICOM I4 THE INTEGER VERSION OF BLANK COMMON 00700005 CA IN/OUT XCOM R4 THE REAL VERSION OF BLANK COMMON 00710005 CA (EQUIVALENCED BY CALLER TO 'ICOM') 00720005 CA IN SIZCOM I4 THE AVAILABLE LENGTH OF BLANK COMMON 00730005 CA 00740005 CA 00750005 CA PURPOSE: TO SERVE AS THE 'PROC' STEERING ROUTINE TO PERFORM 00760005 CA COMBINED AMPLITUDE VS. OFFSET AND VELOCITY ANALYSIS. 00770005 CA 00780005 CA 00790005 C 00800005 C***********************************************************************00810005 C*** ****00820005 C*** SUBROUTINES CALLED BY 'SAAVEL': ****00830005 C*** ****00840005 C***********************************************************************00850005 C 00860005 C 00870005 C ROUTINES CONTAINED AS PART OF THE 'AVEL' PACKAGE 00880005 C ------------------------------------------------ 00890005 C 00900005 C FGAPRT - PRINTS A LIST OF CDPS PROCESSED & THEIR COVERAGE 00910005 C SAHCIC - COLLECTS PRESTACK DATA FOR AVO PROCESSING 00920005 C SAHCSC - PERFORMS OPTIONAL FIRST-TRACE SCALING ON THE DATA 00930005 C SAHCI - PERFORMS AVO PROCESSING OF THE COLLECTED DATA 00940005 C SAHGRAM - COMPUTES THE ATTRIBUTE HISTOGRAM 00950009 C SAMVOT - PERFORMS NORMAL MOVEOUT CORRECTION OF PRESTACK DATA 00960005 C SAVELC - CONVERTS STACKING VELOCITIES TO SLOTHS (V**(-2)) 00970005 C 00980005 C SPARC ROUTINES USED 00990005 C ------------------- 01000005 C 01010005 C ARMVE - COPIES ONE ARRAY INTO ANOTHER 01020005 C ARSET - FILLS AN ARRAY WITH A CONSTANT 01030005 C CKDD - CHECKS FOR THE EXISTENCE OF A DD-CARD 01040005 C DATIME - GETS DATE AND TIME 01050005 C FOCDD - CLOSE A WORK FILE FOR DIRECT ACCESS 01060005 C FOCSD - CLOSE A WORK FILE FOR SEQUENTIAL ACCESS 01070005 C FOIDSD - OPEN A WORK FILE FOR DIRECT ACCESS 01080005 C FOISSD - OPEN A WORK FILE FOR SEQUENTIAL ACCESS 01090005 C FORDSD - READ A RECORD, USING DIRECT ACCESS 01100005 C FOWDSD - WRITE A RECORD, USING DIRECT ACCESS 01110005 C FOWSSD - WRITE A RECORD, USING SEQUENTIAL ACCESS 01120005 C MCOFGN - COMPUTES TRACE INTERPOLATION COEFFICIENTS FOR NMO 01130005 C S1CPCH - COMPARE CHARACTERS 01140005 C S1MVCH - MOVE CHARACTERS BETWEEN ENTITIES OF CONFLICTING TYPE 01150005 C UGUWRK - FREE A WORK FILE 01160005 C UPAWRK - ALLOCATE A WORK FILE 01170005 C UPRESM - RESERVE A BLOCK OF BLANK COMMON 01180005 C USPHD - PRINT THE PROCESS HEADING 01190005 C USPPLT - GENERAL PURPOSE LINE PRINTER PLOT ROUTINE 01200017 C USRTHV - RETRIEVE A TRACE HEADER VALUE 01210005 C USSTHV - STORE A TRACE HEADER VALUE 01220005 C 01230005 C ESSL/SCILIB ROUTINES USED 01240005 C ------------------------- 01250005 C 01260005 C ISAMAX - LOCATES THE INDEX OF THE LARGEST ABSOLUTE VALUE IN A 01270005 C VECTOR 01280005 C SNRM2 - COMPUTES THE EUCLIDEAN NORM OF A VECTOR 01290005 C SSCAL - SCALES A VECTOR BY A CONSTANT MULTIPLIER 01300005 C 01310005 01320005 SUBROUTINE SAAVEL(INH, INTR, OH, OTR, NS, THL, 01330005 * ICOM, XCOM, SIZCOM) 01340005 C 01350030 CJJ IMPLICIT NONE 01360030 IMPLICIT INTEGER (A-Z) 01370030 C 01380005 C***********************************************************************01390005 C*** ****01400005 C*** DECLARATION OF LOCAL VARIABLES: ****01410005 C*** ****01420005 C***********************************************************************01430005 C 01440005 01450005 C SUBROUTINE ARGUMENTS 01460005 C 01470005 INTEGER NS, THL, SIZCOM 01480005 INTEGER INH(THL), OH(THL), ICOM(SIZCOM) 01490005 REAL INTR(NS), OTR(NS), XCOM(SIZCOM) 01500005 C 01510007 C=================================================================== 01520007 C 01530007 C DESCRIPTION OF SEISPARM RECORD ELEMENTS: 01540007 C (ALL ELEMENTS I*4, UNLESS OTHERWISE NOTED) 01550007 C 01560007 C 01570007 C RECORD 1 01580007 C ======== 01590007 C 01600007 C 1 'AVEL' 01610007 C 2 INVOCATION NUMBER 01620007 C 3 DCTYP 'PAR' 01630007 C 4 SCDP STARTING CDP FOR ANALYSIS 01640007 C 5 ECDP ENDING CDP FOR ANALYSIS 01650007 C 6 ANGMAX MAXIMUM INCIDENCE ANGLE FOR ANALYSIS (DEGREES) 01660007 C 7 NCDPMX MAXIMUM NUMBER OF CDP'S TO PROCESS 01670007 C 8 NVEL NUMBER OF VELOCITY FUNCTIONS 01680007 C 9 IGVEL INDEX OF GIVEN VELOCITY FUNCTION 01690007 C 10 VELINC VELOCITY INCREMENT (R*4) 01700007 C 11 MAXTR MAXIMUM CDP TRACE NUMBER TO PROCESS 01710007 C 12 MINTR MINIMUM CDP TRACE NUMBER TO PROCESS 01720007 C 13 IVSMTH LENGTH OF VELOCITY SMOOTHING FILTER 01730007 C 14 IDSMTH LENGTH OF OUTPUT DATA SMOOTHING FILTER 01740007 C 15 IHILBT LENGTH OF HILBERT TRANSFORM FILTER 01750007 C 16 IAORDR ORDER OF 'A' TRACE (0=UNITY; 1=STACK; 2=QUAD; 3=QUARTIC) 01760007 C 17 IBORDR ORDER OF 'B' TRACE (0=UNITY; 1=QUAD; 2=QUARTIC; 3=QS) 01770007 C 18 TPAPT TAU-P APERTURE AS % OF THE MAXIMUM PHYSICAL APERTURE 01780007 C 19 V0 V0 FOR SPHERICAL DIVERGENCE CORRECTION 01790007 C 20 IBOUT OUTPUT TYPE: 0=RE{AB*}, IM{AB*}; 1=RE{A}, IM{AB*}; 01800007 C 2=RE{A}, RE{AB*}; 3=RE{A}, RE{B}. 01810007 C 21 TPFLG 0=X-T DATA; 1=TAU-P DATA. 01820007 C 22 VFLAG IF NONZERO, SUPPRESS VERTICAL SPHERICAL DIVERGENCE 01830007 C 23 ISPHFG IF NONZERO, SUPPRESS HORIZONTAL SPHERICAL DIVERGENCE 01840007 C 24 NMOFLG IF NONZERO, SUPPRESS NMO STRETCH CORRECTION 01850007 C 25 IVIFLG IF NONZERO, INCLUDE INTERVAL VELOCITY CORRECTIONS 01860007 C 26 IFFFLG IF NONZERO, INCLUDE RANGE SCALING FROM FIRST TRACE 01870007 C 27 IAFLG IF 1, SCALE ATTRIBUTES BY |A|. IF 2, SCALE BY |A|**2. 01880007 C 28 IBFLG IF 1, SCALE ATTRIBUTES BY |B|. IF 2, SCALE BY |B|**2. 01890007 C 29 IQFLG IF NONZERO, NUMBER CDP NUMBERS FOR QULR. 01900007 C 30 SCLFLG IF NONZERO, SCALE ATTRIBUTES FOR EACH CDP INDEPENDENTLY. 01910007 C 31 OVRFLG IF NONZERO, OVERRIDE VELOCITY FUNCTION WITH CONSTANT 01920007 C 32 IZFLG IF NONZERO, SUPPRESS 'Q' SCALING BASED ON HISTOGRAM 01930007 C 33 NFILTS NUMBER OF INVERSION FILTERS 01940007 C 34 MXH MAXIMUM HALF-LENGTH OF INVERSION FILTERS 01950007 C 35 ILEN LENGTH OF INTERPOLATION FILTERS 01960007 C 36-40 LENGTH OF INDIVIDUAL INVERSION FILTERS 01970007 C 41 TIDCA TRACE ID CODE OF THE 'A' TRACE 01980007 C 42 TIDCB TRACE ID CODE OF THE 'B' TRACE 01990007 C 43 AVOPCT STRENGTH OF AVO STABILIZATION TERM (R*4) 02000007 C 44 USCALE ATTRIBUTE SCALING PARAMETER (R*4) 02010007 C 45 TARGET VELOCITY OVERRIDE TARGET ZONE (MSECS) 02020007 C 46 STA STARTING ANALYSIS TIME 02030007 C 47 ETA ENDING ANALYSIS TIME 02040007 C 48 TAPER TAPER LENGTH 02050007 C 49 AGC LENGTH OF AGC WINDOW (MSECS) 02060007 C 50 PHROT PHASE ROTATION ANGLE (DEGREES) 02070007 C 51-55 INTERVAL VELOCITY TIME DELAYS (SAMPLES) 02080007 C 56 ROTAB PHASE ROTATION ANGLE IN THE A-B PLANE (R*4) (DEGREES) 02090007 C 57 NHPLOT THE NUMBER OF HISTOGRAM VALUES TO PLOT (1-SIDED) 02100026 C 58 HSTMAX THE VALUE TO THE SCALE THE HISTOGRAM CUTOFF POINT (REAL) 02110026 C 02120007 C RECORD 2 02130007 C ======== 02140007 C 02150007 C 1 'AVEL' 02160007 C 2 INVOCATION NUMBER 02170007 C 3 DCTYP 'H11' 02180007 C 4-SP FIRST H1 FILTER (R*4) 02190007 C 02200007 C RECORD 3 02210007 C ======== 02220007 C 02230007 C 1 'AVEL' 02240007 C 2 INVOCATION NUMBER 02250007 C 3 DCTYP 'H21' 02260007 C 4-SP FIRST H2 FILTER (R*4) 02270007 C 02280007 C 02290007 C RECORDS 2-3 MAY BE REPEATED UP TO 5 TIMES, ONCE FOR EACH 02300007 C NEW PAIR OF INVERSION FILTERS. 02310007 C 02320007 C 02330007 C FORMAT OF OUTPUT PARAMETER RECORDS 02340007 C ================================== 02350007 C 02360007 C 02370007 C RECORD 1 02380007 C ======== 02390007 C 02400007 C WORD 1 2 3 4 5 6 7 8 02410007 C | CHAR | INT | CHAR | INT | INT | INT | INT | INT | 02420007 C |_______|_______|_______|_______|_______|_______|_______|_______| 02430007 C | 'AVEL'| INVOC.| 'PAR '| START | END | MAX | MAX |# VELOC| 02440007 C | | NUMBER| | CDP | CDP | ANGLE |# CDPS |FUNCTNS| 02450007 C 02460007 C WORD 9 10 11 12 13 14 15 16 02470007 C | INT | R*4 | INT | INT | INT | INT | INT | INT | 02480007 C |_______|_______|_______|_______|_______|_______|_______|_______| 02490007 C | VELOC | VELOC | MAX | MIN | VELOC | DATA |HILBERT| 'A' | 02500007 C | INDEX | INCR | CDPT | CDPT | FLTR | FLTR |FTR LEN| ORDER | 02510007 C 02520007 C WORD 17 18 19 20 21 22 23 24 02530007 C | INT | INT | INT | INT | INT | INT | INT | INT | 02540007 C |_______|_______|_______|_______|_______|_______|_______|_______| 02550007 C | 'B' | TAU-P | V0 |OUTPUT | TAU-P | VFLAG |HORIZ | NMO | 02560007 C | ORDER |APERTRE|FT/SEC | TYPE | FLAG | | FLAG | FLAG | 02570007 C 02580007 C WORD 25 26 27 28 29 30 31 32 02590007 C | INT | INT | INT | INT | INT | INT | INT | INT | 02600007 C |_______|_______|_______|_______|_______|_______|_______|_______| 02610007 C |INTERVL|1RST TR|NORM-A |NORM-B |CDP RE-|SCALING|VEL OVR|NO HIST| 02620007 C | FLAG |SCL FLG| FLAG | FLAG |NUMBER?| FLAG | FLAG | FLAG | 02630007 C 02640007 C WORD 33 34 35 36 37 38 39 40 02650007 C | INT | INT | INT | INT | INT | INT | INT | INT | 02660007 C |_______|_______|_______|_______|_______|_______|_______|_______| 02670007 C |# INVR |LONGEST|NMO FLT| FLTR1 | FLTR2 | FLTR3 | FLTR4 | FLTR5 | 02680007 C |FILTERS|FTR LEN| LENGTH| LENGTH| LENGTH| LENGTH| LENGTH| LENGTH| 02690007 C 02700007 C WORD 41 42 43 44 45 46 47 48 02710007 C | INT | INT | REAL | REAL | INT | INT | INT | INT | 02720007 C |_______|_______|_______|_______|_______|_______|_______|_______| 02730007 C |'A' TRC|'B' TRC| NOISE |ATTRIB | TARGET| START | END | TAPER | 02740007 C | TICD | TICD |AVO DB| SCALE | ZONE | TIME | TIME | LENGTH| 02750007 C 02760007 C WORD 49 | 50 | 51 - 55 | 56 | 57 | 02770007 C | INT | INT | REAL REAL REAL REAL | REAL | INT | 02780026 C |_______|_______|_______________________________|_______|_______| 02790007 C |AGC | PHASE | INTERVAL VELOCITY TIME DELAYS | (A,B) |# HIST | 02800026 C | LENGTH| ANGLE |<----------------------------->| ANGLE |TO PLOT| 02810026 C 02820007 C WORD 58 58 - 108 02830026 C | REAL | NOT USED | 02840026 C |_______|_______________________________________________________| 02850026 C |HISTGRM| | 02860026 C | CUTOFF|<----------------------------------------------------->| 02870026 C 02880007 C RECORD 2 02890007 C ======== 02900007 C 02910007 C WORD 1 2 3 4 THROUGH 'SEISPRM' 02920007 C | CHAR | INT | CHAR | | 02930007 C |_______|_______|_______|_____________________| 02940007 C | 'AVEL'| INVOC.| 'H11 '| FIRST H1 INVERSION | 02950007 C |_______| NUMBER|_______| FILTER | 02960007 C 02970007 C 02980007 C RECORD 3 02990007 C ======== 03000007 C 03010007 C WORD 1 2 3 4 THROUGH 'SEISPRM' 03020007 C | CHAR | INT | CHAR | | 03030007 C |_______|_______|_______|_____________________| 03040007 C | 'AVEL'| INVOC.| 'H21 '| FIRST H2 INVERSION | 03050007 C |_______|NUMBER_|_______| FILTER | 03060007 C 03070007 C 03080007 C RECORD 4 03090007 C ======== 03100007 C 03110007 C WORD 1 2 3 4 THROUGH 'SEISPRM' 03120007 C | CHAR | INT | CHAR | | 03130007 C |_______|_______|_______|_____________________| 03140007 C | 'AVEL'| INVOC.| 'H12 '| SECOND H1 INVERSION | 03150007 C |_______|NUMBER_|_______| FILTER | 03160007 C 03170007 C 03180007 C RECORD 2 03190007 C ======== 03200007 C 03210007 C WORD 1 2 3 4 THROUGH 'SEISPRM' 03220007 C | CHAR | INT | CHAR | | 03230007 C |_______|_______|_______|_____________________| 03240007 C | 'AVEL'| INVOC.| 'H22 '| SECOND H2 INVERSION | 03250007 C |_______|NUMBER_|_______| FILTER | 03260007 C 03270007 C ETC. 03280007 C 03290007 C====================================================================== 03300007 C TRACE HEADER VALUES ARE SET FOR LATER REFERENCE OF TRACES: 03310005 C 03320005 C THTICD = TRACE IDENTIFICATION CODE 03330005 C THNHST = HORIZONTAL STACKING FOLD 03340005 C THFLV = FIRST LIVE VALUE 03350005 C 03360005 C 03370005 C====================================================================== 03380005 C====================================================================== 03390005 C 03400005 C COMMON /P/ VARIABLES REFERENCED (IN EITHER PREP OR PROC STEPS): 03410005 C 03420005 C ACLNAM -- ACCOUNT CARD LINE NAME 03430005 C KPBUGF -- CURRENT PROCESS DEBUG FLAG 03440005 C KPDRTF -- CURRENT PROCESS DEFAULT RETURN FLAG 03450005 C KPFCF -- CURRENT PROCESS FIRST CALL FLAG 03460005 C KPIRSM -- CURRENT PROCESS RESERVED SCRATCH MEMORY START 03470005 C KPIUSM -- CURRENT PROCESS UNRESERVED SCRATCH MEMORY START 03480005 C KPLOTF -- CURRENT PROCESS FLUSH FLAG (OUTPUT WITHOUT INPUT) 03490005 C KPMITF -- CURRENT PROCESS MORE INPUT FLAG 03500005 C KPMOTF -- CURRENT PROCESS MORE OUTPUT FLAG 03510005 C KPNA -- CURRENT PROCESS NAME 03520005 C KPNRSM -- CURRENT PROCESS NUMBER OF RESERVED WORDS 03530005 C KPNUSM -- CURRENT PROCESS NUMBER OF UNRESERVED WORDS 03540005 C KPPRNT -- CURRENT PROCESS PRINT UNIT NUMBER 03550005 C KPRNO -- CURRENT PROCESS OCCURRANCE NUMBER 03560005 C KPRTF -- CURRENT PROCESS RETURN FLAG 03570005 C KPWARN -- CURRENT PROCESS WARNING FLAG 03580005 C KPWRKD -- CURRENT PROCESS 1RST DIRECT ACCESS FILE DCB 03590005 C KPWRKS -- CURRENT PROCESS 1RST SEQUENTIAL ACCESS FILE DCB 03600005 C KPWKD2 -- CURRENT PROCESS 2ND DIRECT ACCESS FILE DCB 03610005 C KPWKS2 -- CURRENT PROCESS 2ND SEQUENTIAL ACCESS FILE DCB 03620005 C LCMXFD -- LINE CARD MAXIMUM CDP FOLD 03630005 C LCNSP -- LINE CARD NUMBER OF DEPTH POINTS ON THE LINE 03640005 C LCPI -- LINE CARD PROCESSING INTERVAL 03650005 C LCRL -- LINE CARD RECORD LENGTH 03660005 C LCSI -- LINE CARD INPUT SAMPLING INTERVAL 03670005 C LCTYP -- LINE CARD PROCESSING MODE 03680005 C 03690005 C 03700005 03710005 C 03720005 C THE FOLLOWING ARE REALLY CHARACTER VARIABLES, DECLARED AS INTEGERS 03730005 C FOR THE BENEFIT OF THE CRAY: 03740005 C 03750005 C CHARACTER*4 LCINT, LCTYP, SYSTM 03760005 C CHARACTER*20 ACLNAM 03770005 C CHARACTER*32 ACCOM 03780005 C CHARACTER*20 ACUSER 03790005 C CHARACTER*16 JAPNMS 03800005 C 03810005 INTEGER ACLNAM(5) 03820005 INTEGER ACCOM(8) 03830005 INTEGER ACUSER(5) 03840005 INTEGER JAPNMS(4) 03850005 INTEGER LCINT, LCTYP, SYSTM 03860005 C 03870005 C THE FOLLOWING ARE REALLY WHAT THEY ARE DECLARED TO BE. 03880005 C 03890005 INTEGER STARTP(2) 03900005 INTEGER LCNAME, LC5, LC10, LCBGSP 03910005 INTEGER LCENSP, LCNSP, LCTPSP, LCRL 03920005 INTEGER LCSI, LCPI, LCGRPI, LCMXFD, LCDRYF, ACNAME, AC0506 03930005 INTEGER AC64BC, ACOPCD, ACQCF, ACDIST, ACPROJ 03940005 INTEGER AC7274, ACTYPE, ACNSP, LHJBNO, LHTPSP 03950005 INTEGER LHATSP, LHSI, LHORSI, LHST, LHORST, LHDFCD, LHEXFD 03960005 INTEGER LHTSCD, LHVSCD, LHSWFS, LHSWFE, LHSWL, LHSWCD, LHTSNO 03970005 INTEGER LHSWTE, LHSWTS, LHSWTT, LHTCF, LHBGRF, LHARCD 03980005 INTEGER LHMS, LHSGPL, LHVPCD, LHNSP, LHNDP, LHNSL, LHMTPR 03990005 INTEGER KPNA, KPRNO, KPOCUR, KPA, KPDBGS, KPDBGA, KPDBGN 04000005 INTEGER KPWRKD, KPWKD2, KPWKS3, KPIRSM, KPNRSM, KPIUSM 04010005 INTEGER KPNUSM, KPTIME, KPDRTF, KPMOTF, KPNBR, KPIBN 04020005 INTEGER KPRTF, KPVOLS, KPBUGF, KPITSV, KPFCF, KPWKD3, KPWKS2 04030005 INTEGER LHWD32, LHRLNO, LHLNO, KPWRKS, KPWARN 04040005 INTEGER KPTAMF, KPLOTF, KPMITF, KPPRNT, KPPLOT, KPPLTA 04050005 INTEGER KPTRIO, PROTAB, ENDP, SYBYPW, SYLOCF 04060005 INTEGER M00032, M00068, M00080, M00188, M00540, M00548, M00556 04070005 C 04080005 COMMON /P/ STARTP 04090005 COMMON /P/ LCNAME 04100005 COMMON /P/ LC5 04110005 COMMON /P/ LCINT 04120005 COMMON /P/ LCTYP 04130005 COMMON /P/ LC10 04140005 COMMON /P/ LCBGSP 04150005 COMMON /P/ LCENSP , M00032( 2) 04160005 COMMON /P/ LCNSP 04170005 COMMON /P/ LCTPSP 04180005 COMMON /P/ LCRL 04190005 COMMON /P/ LCSI 04200005 COMMON /P/ LCPI 04210005 COMMON /P/ LCGRPI 04220005 COMMON /P/ LCMXFD , M00068( 2) 04230005 COMMON /P/ LCDRYF , M00080( 3) 04240005 COMMON /P/ ACNAME 04250005 COMMON /P/ AC0506 04260005 COMMON /P/ AC64BC 04270005 COMMON /P/ ACOPCD 04280005 COMMON /P/ ACQCF 04290005 COMMON /P/ ACDIST 04300005 COMMON /P/ ACPROJ 04310005 COMMON /P/ ACLNAM 04320005 COMMON /P/ ACCOM 04330005 COMMON /P/ AC7274 04340005 COMMON /P/ ACTYPE 04350005 COMMON /P/ ACNSP 04360005 COMMON /P/ ACUSER , M00188( 12) 04370005 COMMON /P/ LHJBNO 04380005 COMMON /P/ LHLNO 04390005 COMMON /P/ LHRLNO 04400005 COMMON /P/ LHTPSP 04410005 COMMON /P/ LHATSP 04420005 COMMON /P/ LHSI 04430005 COMMON /P/ LHORSI 04440005 COMMON /P/ LHST 04450005 COMMON /P/ LHORST 04460005 COMMON /P/ LHDFCD 04470005 COMMON /P/ LHEXFD 04480005 COMMON /P/ LHTSCD 04490005 COMMON /P/ LHVSCD 04500005 COMMON /P/ LHSWFS 04510005 COMMON /P/ LHSWFE 04520005 COMMON /P/ LHSWL 04530005 COMMON /P/ LHSWCD 04540005 COMMON /P/ LHTSNO 04550005 COMMON /P/ LHSWTS 04560005 COMMON /P/ LHSWTE 04570005 COMMON /P/ LHSWTT 04580005 COMMON /P/ LHTCF 04590005 COMMON /P/ LHBGRF 04600005 COMMON /P/ LHARCD 04610005 COMMON /P/ LHMS 04620005 COMMON /P/ LHSGPL 04630005 COMMON /P/ LHVPCD 04640005 COMMON /P/ LHNSP 04650005 COMMON /P/ LHNDP 04660005 COMMON /P/ LHNSL 04670005 COMMON /P/ LHMTPR 04680005 COMMON /P/ LHWD32 ( 9) 04690005 COMMON /P/ KPNA 04700005 COMMON /P/ KPRNO 04710005 COMMON /P/ KPOCUR 04720005 COMMON /P/ KPA 04730005 COMMON /P/ KPDBGS 04740005 COMMON /P/ KPDBGA 04750005 COMMON /P/ KPDBGN 04760005 COMMON /P/ KPWRKS 04770005 COMMON /P/ KPWRKD 04780005 COMMON /P/ KPWKS2 04790005 COMMON /P/ KPWKD2 04800005 COMMON /P/ KPWKS3 04810005 COMMON /P/ KPWKD3 04820005 COMMON /P/ KPFCF 04830005 COMMON /P/ KPIRSM 04840005 COMMON /P/ KPNRSM 04850005 COMMON /P/ KPIUSM 04860005 COMMON /P/ KPNUSM 04870005 COMMON /P/ KPTIME 04880005 COMMON /P/ KPRTF 04890005 COMMON /P/ KPDRTF 04900005 COMMON /P/ KPMOTF 04910005 COMMON /P/ KPNBR 04920005 COMMON /P/ KPIBN 04930005 COMMON /P/ KPITSV 04940005 COMMON /P/ KPTAMF 04950005 COMMON /P/ KPLOTF 04960005 COMMON /P/ KPMITF 04970005 COMMON /P/ KPPRNT 04980005 COMMON /P/ KPPLOT 04990005 COMMON /P/ KPPLTA 05000005 COMMON /P/ KPBUGF 05010005 COMMON /P/ KPWARN 05020005 COMMON /P/ KPTRIO , M00548 05030005 COMMON /P/ KPVOLS , M00556( 220) 05040005 COMMON /P/ PROTAB (2) 05050005 COMMON /P/ ENDP 05060005 C 05070005 C SYSTEM ENVIRONMENT VARIABLES 05080005 C 05090005 COMMON /SYSTEM/ SYSTM, SYBYPW, SYLOCF, JAPNMS 05100005 C 05110005 C 05120005 C=================================================================== 05130005 C 05140005 C SEISPARM RECORD ARRAY FOR PROCESS 'AVEL': 05150005 C 05160005 C 05170005 C FIXED ARRAY LENGTHS: 05180005 C ==================== 05190005 C 05200005 C 05210005 C 'HSTSZE' - THE NUMBER OF POINTS IN THE HISTOGRAM (INTEGER) 05220014 C 'LRC' - THE FIRST SEISPARM RECORD LENGTH (104) 05230005 C 'MMXH' - THE MAXIMUM ALLOWABLE INVERSION FILTER HALF LENGTH 05240005 C (LIMITED BY THE SEISPARM RECORD LENGTH). 05250005 C 'NSEIS' - THE NUMBER OF SEISPARM RECORDS RESIDENT AT ANY 05260005 C PARTICULAR TIME. 05270005 C 'MAXNFT' - THE MAXIMUM NUMBER OF INVERSION FILTERS TO TRY 05280005 C IN A SINGLE RUN. 05290005 C 'IPUNIT' - IS AN UNUSED FORTRAN UNIT NUMBER, USED FOR 05300005 C GENERATING TELAGRAF PLOT FILES FOR DEBUGGING. 05310005 C 'PI' - IS THE RATIO OF THE CIRCUMFERENCE OF A CIRCLE 05320005 C TO ITS DIAMETER. 05330005 C 'RADIAN' - 1 RADIAN, EXPRESSED IN DEGREES 05340005 C 'SEISPRM' - THR MAXIMUM SEISPARM LENGTH 05350005 C 05360005 INTEGER MMXH, NSEIS, IPUNIT, MAXNFT, LRC, SEISPRM, HSTZSE 05370013 INTEGER HSTSZE 05380014 REAL PI, RADIAN 05390026 PARAMETER (NSEIS=3, MAXNFT=5, LRC=104, SEISPRM=204) 05400005 PARAMETER (MMXH=(SEISPRM-4)/2, IPUNIT=49, HSTSZE=1000) 05410020 PARAMETER (RADIAN=57.2958, PI=3.141593) 05420005 INTEGER DENTRY(SEISPRM, NSEIS) 05430005 C 05440005 C PARAMETER RECORD 1 05450005 C 05460005 INTEGER DCTYP1 05470005 INTEGER SCDP, ECDP, ANGMAX, VFLAG, V0, IBOUT 05480005 INTEGER NVEL, IGVEL, MAXTR, MINTR, IVSMTH, TPAPT 05490005 INTEGER IDSMTH, IHILBT, IAORDR, IBORDR, NOTUS1 05500005 INTEGER NCDPMX, TIDCA, TIDCB, NHPLOT 05510026 REAL VELINC, AVOPCT, USCALE, ROTAB, HSTMAX 05520026 05530005 EQUIVALENCE( DCTYP1, DENTRY(03, 1) ) 05540005 EQUIVALENCE( SCDP , DENTRY(04, 1) ) 05550005 EQUIVALENCE( ECDP , DENTRY(05, 1) ) 05560005 EQUIVALENCE( ANGMAX, DENTRY(06, 1) ) 05570005 EQUIVALENCE( NCDPMX, DENTRY(07, 1) ) 05580005 EQUIVALENCE( NVEL , DENTRY(08, 1) ) 05590005 EQUIVALENCE( IGVEL , DENTRY(09, 1) ) 05600005 C 05610005 EQUIVALENCE( VELINC, DENTRY(10, 1) ) 05620005 EQUIVALENCE( MAXTR , DENTRY(11, 1) ) 05630005 EQUIVALENCE( MINTR , DENTRY(12, 1) ) 05640005 EQUIVALENCE( IVSMTH, DENTRY(13, 1) ) 05650005 EQUIVALENCE( IDSMTH, DENTRY(14, 1) ) 05660005 EQUIVALENCE( IHILBT, DENTRY(15, 1) ) 05670005 EQUIVALENCE( IAORDR, DENTRY(16, 1) ) 05680005 EQUIVALENCE( IBORDR, DENTRY(17, 1) ) 05690005 EQUIVALENCE( TPAPT , DENTRY(18, 1) ) 05700005 EQUIVALENCE( V0 , DENTRY(19, 1) ) 05710005 C 05720005 EQUIVALENCE( IBOUT , DENTRY(20, 1) ) 05730005 C 05740005 C THE PROGRAM FLAGS: 05750008 C 05760005 INTEGER NFLAGS, ISPHFG, NMOFLG, IVIFLG, IFFFLG, IAFLG, IBFLG 05770005 INTEGER IQFLG, SCLFLG, OVRFLG, TPFLG, IZFLG 05780008 PARAMETER (NFLAGS = 12) 05790008 INTEGER FLAGS(NFLAGS) 05800005 05810005 EQUIVALENCE( TPFLG ,FLAGS,DENTRY(21, 1) ) 05820005 EQUIVALENCE( VFLAG , DENTRY(22, 1) ) 05830005 EQUIVALENCE( ISPHFG, DENTRY(23, 1) ) 05840005 EQUIVALENCE( NMOFLG, DENTRY(24, 1) ) 05850005 EQUIVALENCE( IVIFLG, DENTRY(25, 1) ) 05860005 EQUIVALENCE( IFFFLG, DENTRY(26, 1) ) 05870005 EQUIVALENCE( IAFLG, DENTRY(27, 1) ) 05880005 EQUIVALENCE( IBFLG, DENTRY(28, 1) ) 05890005 EQUIVALENCE( IQFLG, DENTRY(29, 1) ) 05900005 EQUIVALENCE( SCLFLG, DENTRY(30, 1) ) 05910005 EQUIVALENCE( OVRFLG, DENTRY(31, 1) ) 05920005 EQUIVALENCE( IZFLG, DENTRY(32, 1) ) 05930008 C 05940005 C VARIOUS FILTER LENGTHS 05950005 C 05960005 INTEGER LFLTR, NFILTS, MXH, ILEN, TARGET, STA, ETA, NOTUS2 05970005 INTEGER TAPER, AGC, PHROT, NOTUS3 05980005 REAL VFLEN 05990005 DIMENSION LFLTR(MAXNFT), VFLEN(MAXNFT) 06000005 06010005 EQUIVALENCE( NFILTS, DENTRY(33, 1) ) 06020008 EQUIVALENCE( MXH , DENTRY(34, 1) ) 06030008 EQUIVALENCE( ILEN , DENTRY(35, 1) ) 06040008 EQUIVALENCE( LFLTR , DENTRY(36, 1) ) 06050008 EQUIVALENCE( TIDCA , DENTRY(41, 1) ) 06060008 EQUIVALENCE( TIDCB , DENTRY(42, 1) ) 06070008 EQUIVALENCE( AVOPCT, DENTRY(43, 1) ) 06080008 EQUIVALENCE( USCALE, DENTRY(44, 1) ) 06090008 EQUIVALENCE( TARGET, DENTRY(45, 1) ) 06100008 EQUIVALENCE( STA , DENTRY(46, 1) ) 06110008 EQUIVALENCE( ETA , DENTRY(47, 1) ) 06120008 EQUIVALENCE( TAPER , DENTRY(48, 1) ) 06130008 EQUIVALENCE( AGC , DENTRY(49, 1) ) 06140008 EQUIVALENCE( PHROT , DENTRY(50, 1) ) 06150008 EQUIVALENCE( VFLEN , DENTRY(51, 1) ) 06160008 EQUIVALENCE( ROTAB , DENTRY(56, 1) ) 06170008 EQUIVALENCE( NHPLOT, DENTRY(57, 1) ) 06180026 EQUIVALENCE( HSTMAX, DENTRY(58, 1) ) 06190026 EQUIVALENCE( NOTUS2, DENTRY(59, 1) ) 06200026 EQUIVALENCE( NOTUS3, DENTRY(60, 1) ) 06210026 C 06220005 C PARAMETER RECORD 2 06230005 C 06240005 INTEGER DCTYP2 06250005 REAL H1(-MMXH:MMXH) 06260005 EQUIVALENCE( DCTYP2, DENTRY(03, 2) ) 06270005 EQUIVALENCE( H1 , DENTRY(04, 2) ) 06280005 C 06290005 C PARAMETER RECORD 3 06300005 C 06310005 INTEGER DCTYP3 06320005 REAL H2(-MMXH:MMXH) 06330005 EQUIVALENCE( DCTYP3, DENTRY(03, 3) ) 06340005 EQUIVALENCE( H2 , DENTRY(04, 3) ) 06350005 C 06360005 C FIXED ARRAY SIZES 06370005 C ================= 06380005 C 06390005 C NPARM THE SIZE OF THE PARAMETER ARRAY FOR SUBROUTINE 'SAHCI'. 06400005 C PTBSIZ THE SIZE OF THE PRINTER BUFFER WHICH HOLDS CDPS PROCESSED 06410005 C ISZ THE SECOND DIMENSION OF THE COLLECTION ARRAY, 'S'. 06420005 C NUA THE NUMBER OF UNRESERVED TRACE-LENGTH ARRAYS NEEDED 06430005 C NZ THE SIZE IN WORDS OF THE SEISMIC HEADER RECORD 06440005 C 06450005 INTEGER NPARM, PTBSIZ, ISZ, NUA, NZ 06460005 PARAMETER (NPARM=14, PTBSIZ=10, ISZ=8, NUA=6, NZ=100) 06470005 C 06480005 C SAVED INTEGER VARIABLES 06490005 C ======================= 06500005 C 06510005 C BIGCDP THE CDP NUMBER HAVING THE LARGEST ABSOLUTE ATTRIBUTE 06520005 C CDPNDX INDEX IN RESERVED COMMON TO THIS CDP'S SCALE FACTOR 06530005 C CDPSCL POINTER TO RESERVED COMMON TO AN ARRAY CONTAINING 06540005 C THE MAXIMUM ABSOLUTE ATTRIBUTE IN EACH CDP 06550005 C COEF POINTER TO START OF NMO INTERPOLATION COEFFICIENTS 06560005 C CURHD INDEX IN RESERVED COMMON OF A CURRENT HEADER TEMPLATE 06570005 C DATANO THE RECORD NUMBER IN SCRATCH FILE #1 FOR THE NEXT DATA TRCE06580005 C ENDCOM THE LAST LOCATION OF RESERVED BLANK COMMON 06590005 C EOF1 ONE PLUS THE LAST RECORD NUMBER OF WORK FILE 1 06600005 C EOF2 ONE PLUS THE LAST RECORD NUMBER OF WORK FILE 2 06610005 C FILEP1 THE NEXT RECORD TO READ OR WRITE TO WORK FILE 1 06620005 C FILEP2 THE NEXT RECORD TO READ OR WRITE TO WORK FILE 2 06630005 C FNDX THE INDEX OF THE INVERSION FILTERS BEING USED 06640005 C FOLD THE FOLD OF THIS CDP GATHER 06650005 C FSA THE INDEX OF THE FIRST SAMPLE TO ANALYZE 06660005 C FSFLAG FIRST LIVE TRACE SCALING FLAG 06670005 C FWTR THE DENTRY INDEX OF THE 1RST WORD OF THE LAST SEISPRM REC 06680005 C IPU THE PLOTTER UNIT NUMBER, IF OPENED. 06690005 C IVEL THE NUMBER OF THE VELOCITY PROFILE WE'RE WORKING ON 06700005 C LSTCDP THE CDP NUMBER WE'RE WORKING ON 06710005 C MINFLV THE MINIMUM FIRST LIVE VALUE (AFTER NMOC) OF ALL TRACES 06720005 C IN THE CDP GATHER 06730005 C NCPROC THE NUMBER OF CDPS PROCESSED SO FAR 06740005 C NEWHD POINTER TO RESERVED COMMON TO HOLD THE CORRESPONDING 06750005 C TRACE HEADER 06760005 C NEWTR POINTER TO RESERVED COMMON, TO HOLD THE FIRST TRACE 06770005 C OF THE NEXT CDP GATHER, WHILE THE LAST GATHER IS STILL 06780005 C BEING PROCESSED 06790005 C NFILL THE BLANK SPACE IN FRONT OF THE FILTER COEFFICIENTS 06800005 C NOVEL THE NUMBER OF CDPS FOR WHICH THERE WERE NO VELOCITY FNS 06810005 C NOWDS THE NUMBER OF WORDS RESERVED BY AVEL 06820005 C NREC NUMBER OF NEXT PARAMETER RECORD TO READ 06830005 C NRPF THE NUMBER OF SEISPARM RECORDS PER FILTER 06840005 C NSA THE NUMBER OF SAMPLES TO BE COMPUTED PER TRACE 06850005 C NWORDS THE INDEX OF THE FIRST WORD TO READ FROM THIS SEISPARM REC 06860005 C PARM ARRAY OF 'NPARM' PARAMETERS FOR 'HCI' 06870005 C PTBCDP POINTER TO THE START OF THE CDP PRINTER BUFFER 06880005 C PTBFLD POINTER TO THE START OF THE MAXIMUM ANGLE BUFFER. 06890005 C PTBPTR POINTER TO NEXT SPOT IN PRINT BUFFER 06900005 C SCLTYP 2=HISTOGRAM SCALING; 1=OTHER SCALING 06910016 C SIZEU THE REQUIRED NUMBER OF UNRESERVED BLANK COMMON WORDS 06920005 C VELPNO THE RECORD NUMBER IN SCRATCH FILE #1 FOR THE VELOCITY TRACE06930005 C WDSTREAD THE NUMBER OF WORDS TO READ FROM THIS SEISPARM RECORD 06940005 C WKNRC1 THE MAXIMUM NUMBER OF RECORDS ON WORK FILE #1 06950005 C WKNRC2 THE MAXIMUM NUMBER OF RECORDS ON WORK FILE #2 06960005 C 06970005 INTEGER ENDCOM, COEF, PARM(NPARM), SIZEU 06980005 INTEGER FOLD, LSTCDP, PTBPTR, FNDX, MINFLV 06990005 INTEGER PTBCDP, PTBFLD, NREC, NEWTR, NEWHD 07000005 INTEGER FILEP1, FILEP2, EOF1, EOF2, IVEL, NOWDS 07010005 INTEGER WKNRC1, WKNRC2, IPU, FSFLAG, SCLTYP 07020016 INTEGER CDPSCL, NSA, FSA, NOVEL, CURHD 07030005 INTEGER CDPNDX, NCPROC, BIGCDP, VELPNO, DATANO, NWORDS 07040005 INTEGER NRPF, FWTR, NFILL, WDSTREAD 07050005 C 07060005 C SAVED LOGICAL VARIABLES 07070005 C ======================= 07080005 C 07090005 C VELFG TRUE IF THIS CDP HAS A VELOCITY FUNCTION DEFINED 07100005 C MOVEFG TRUE IF THE DATA ARE TO BE NMO-CORRECTED 07110005 C OV2FLG TRUE IF WORK FILE #2 HAS OVERFLOWED. 07120005 C 07130005 LOGICAL VELFG, MOVEFG, DIPFG, LOOPX, OV2FLG 07140005 C 07150005 C SAVED REAL VARIABLES 07160005 C ==================== 07170005 C 07180005 C ALIM SIN **2 (ANGMAX) 07190005 C ANGBIG THE LARGEST INCIDENCE ANGLE AT TARGET ZONE 07200005 C ASCALE LARGEST ATTRIBUTE IN ABSOLUTE MAGNITUDE 07210005 C FS THE SAMPLING FREQUENCY (HZ) 07220005 C FSCALE FIRST LIVE TRACE SCALING FACTOR 07230005 C RMSLIN THE PRIMARY DATA RMS LEVEL FOR THE WHOLE LINE 07240005 C RMSMAX THE MAXIMUM PRIMARY DATA RMS LEVEL FOR THIS CDP 07250005 C VTARG THE STACKING VELOCITY AT THE TARGET ZONE (FT/SEC) 07260005 C 07270005 REAL FS, ALIM, FSCALE, ASCALE, ANGBIG, VTARG, RMSLIN, RMSMAX 07280005 C 07290005 C SCRATCH CHARACTER VARIABLES 07300005 C --------------------------- 07310005 C 07320005 C DD1 NAME OF SCRATCH FILE #1 07330005 C DD2 NAME OF SCRATCH FILE #2 07340005 C PDD TEMPORARY VARIABLE FOR PDDNAME 07350005 C PDDNAME NAME OF OUTPUT FILE FOR MOVED OUT GATHERS (IBM, ONLY) 07360005 C VERSION DATE OF LAST REVISION 07370005 C WHEN USED BY DATE / TIME ROUTINES 07380005 C 07390005 CHARACTER*12 VERSION 07400005 CHARACTER*4 WHEN(5), DC(NSEIS) 07410005 CHARACTER*8 DD1, DD2, DDNAME 07420005 CHARACTER*8 PDD,PDDNAME 07430005 CHARACTER*3 FTEXT(2) 07440016 C 07450005 C SCRATCH (LOCAL) INTEGER VARIABLES 07460005 C --------------------------------- 07470005 C 07480005 C DIPANG INDEX OF SCRATCH COMMON FOR THE DIP ANGLE 07490005 C DREC THE DESIRED SEISPARM RECORD NUMBER 07500005 C ERIN AN SVC99 RETURN CODE 07510005 C ERR ERROR RETURN FROM UPAWRK AND UGUWRK 07520005 C FSMP INDEX OF FIRST LIVE SAMPLE UNDER ANALYSIS, AFTER MOVEOUT 07530005 C HEAD INDEX OF SCRATCH COMMON TO SAVE THE INPUT HEADER 07540005 C HNDX INDEX INTO THE SCRATCH ARRAY OF START OF PLOTTED HISTOGRAM 07550020 C I INDEX OF DO-LOOP 07560005 C IBULK DELAY RECORDING TIME FROM TRACE HEADER 07570005 C ICDPN CDP NUMBER FROM HEADER 07580005 C ICDPT CDP TRACE NUMBER FROM HEADER 07590005 C IER ERROR FLAG USED BY SAVELC 07600005 C IFLV FIRST LIVE VALUE FROM HEADER 07610005 C ILEN2 ILEN/2 07620005 C ILLV LAST LIVE VALUE FROM HEADER 'THOT' 07630005 C INFSA INDEX OF SCRATCH COMMON OF FIRST SAMPLE UNDER ANALYSIS 07640005 C IPR FORTRAN PRINTER UNIT NUMBER 07650005 C ISI SAMPLING INTERVAL (USECS) FROM HEADER 07660005 C ITICD TRACE ID CODE FROM HEADER 07670005 C ITP THE "P" VALUE FOR TAU-P GATHERS 07680005 C IXOFF SHOT-RECEIVER OFFSET FROM HEADER 07690005 C J RUNTIME OF PROCESS 07700005 C KPBEG BEGINNING OF BLANK COMMON 07710005 C KPBEG2 BEGINNING OF BLANK COMMON (DOUBLE WORD BNDRY) 07720005 C LSA INDEX OF LAST SAMPLE UNDER ANALYSIS 07730005 C LSMP INDEX OF LAST LIVE SAMPLE UNDER ANALYSIS, AFTER MOVEOUT 07740005 C NHPTS NUMBER OF HISTOGRAM VALUES TO PLOT (2-SIDED) 07750020 C NTCR THE NUMBER OF RECEIVERS TO THE LEFT OF THE SHOT 07760005 C NTDP THE NUMBER OF RECEIVERS TO THE RIGHT OF THE SHOT 07770005 C S POINTER TO START OF RUNNING SUM ARRAY 07780005 C SCRATCH POINTER TO DOUBLE-WORD BNDRY UNRESERVED ARRAY FOR 'SAHCIC' 07790005 C SHOT SHOT POINT NEAREST THE COMMON DEPTH POINT 07800005 C SLOTH POINTER TO START OF STACKING SLOTH ARRAY 07810005 C SLOTHI POINTER TO START OF INTERVAL SLOTH ARRAY 07820005 C TRCOEF POINTER TO START OF TRACE INTERPOLATION ARRAY 07830005 C TRSAVE INDEX OF SCRATCH COMMON TO SAVE THE INPUT TRACE 07840005 C WKNREC SCRATCH FILE LENGTH 07850005 C WKRECL SCRATCH FILE RECORD LENGTH 07860005 C 07870005 INTEGER WKNREC, WKRECL, ITICD, ICDPT, ICDPN, IXOFF 07880005 INTEGER ISI, IFLV, KPBEG, KPBEG2, IPR, ILEN2 07890005 INTEGER S, I, J,SLOTH, SLOTHI, ERR, ERIN, IBULK 07900005 INTEGER TRCOEF, IER, LSA, DREC, FSMP, ITP 07910005 INTEGER HEAD, TRSAVE, INFSA, LSMP, SHOT, SCRATCH 07920005 INTEGER DIPANG, NTDP, NTCR, ILLV, HNDX 07930026 INTEGER NHPTS 07940021 C 07950005 C SCRATCH REAL VARIABLES AND ARRAYS 07960005 C --------------------------------- 07970005 C 07980005 C ARRAYS A, FF, G, RW, AND BW ARE FOR CHARLES SICKING'S INTERPOLATOR. 07990005 C 08000005 C ANGLE INCIDENCE ANGLE AT TARGET ZONE (DEGREES) 08010005 C CSCALE BIGGEST ABSOLUTE ATTRIBUTE MAGNITUDE IN CURRENT CDP SO FAR 08020005 C DESIRE THE DESIRED ATTRIBUTE LEVEL FOR THIS CDP 08030005 C PHYSAP THE PHYSICAL APERTURE LIMITS (FEET) 08040005 C SPDP THE DEPTH POINT SPACING OF THIS CDP (FEET) 08050005 C TEMP A TEMPORARY VARIABLE 08060005 C TSAMP SAMPLING INTERVAL (SECS) 08070005 C T0 DELAY IN RECORDING TIME (SECS) 08080005 C T0M TIME OF FIRST SAMPLE RELEVANT TO NMO CORRECTION 08090005 C T0S TIME OF FIRST SAMPLE UNDER ANALYSIS (SECS) 08100005 C VINC VELOCITY INCREMENT (FT/SEC) 08110005 C XOFF SHOT-RECEIVER OFFSET (FT) 08120005 C 08130005 REAL A, FF, G, RW 08140005 DIMENSION A(14), FF(14), G(14), RW(12) 08150005 REAL BW(6), DESIRE, SPDP, PHYSAP(2) 08160005 REAL XOFF, TSAMP, T0, VINC, T0S, T0M, CSCALE, TEMP, ANGLE 08170005 C 08180005 C OTHER SCRATCH VARIABLES 08190005 C ----------------------- 08200005 C 08210005 C CPYFLG .TRUE. IF THE CURRENT INPUT TRACE IS TO BE SAVED 08220005 C .FALSE. IF THE SAVED TRACE IS ALREADY IN PLACE 08230005 C 08240005 LOGICAL CPYFLG 08250005 08260005 C FUNCTION DECLARTIONS 08270005 C -------------------- 08280005 C 08290005 C ISAMAX FIND INDEX OF LARGEST MAGNITUDE VECTOR ELEMENT 08300005 C (ESSL AND SCILIB ROUTINE) 08310005 C SNRM2 EUCLIDEAN NORM OF A REAL VECTOR 08320005 C (ESSL AND SCILIB ROUTINE) 08330005 C S1CPCH COMPARE CHARACTERS ELEMENTS 08340005 C (SPARC ROUTINE) 08350005 C 08360005 INTEGER ISAMAX, S1CPCH 08370005 REAL SNRM2 08380005 C 08390005 C ALLOCATION OF SAVE AREA 08400005 C ('XLOCAL' IS ONE PLUS THE NUMBER OF DLOCAL ENTRIES, BELOW) 08410005 C 08420005 INTEGER XLOCAL, LLOCAL 08430005 PARAMETER (XLOCAL=55) 08440005 PARAMETER (LLOCAL=NSEIS*SEISPRM+XLOCAL+NPARM) 08450005 INTEGER DLOCAL(LLOCAL) 08460005 EQUIVALENCE (DLOCAL(XLOCAL+NPARM+1), DENTRY) 08470005 C 08480005 C LOCAL SAVED SCALARS (DEFINED ABOVE) 08490005 C 08500005 EQUIVALENCE (DLOCAL(09), ALIM ) 08510005 EQUIVALENCE (DLOCAL(35), ANGBIG) 08520005 EQUIVALENCE (DLOCAL(30), ASCALE) 08530005 EQUIVALENCE (DLOCAL(43), BIGCDP) 08540005 EQUIVALENCE (DLOCAL(39), CDPNDX) 08550005 EQUIVALENCE (DLOCAL(31), CDPSCL) 08560005 EQUIVALENCE (DLOCAL(04), COEF ) 08570005 EQUIVALENCE (DLOCAL(38), CURHD ) 08580005 EQUIVALENCE (DLOCAL(46), DATANO) 08590005 EQUIVALENCE (DLOCAL(44), DIPFG ) 08600005 EQUIVALENCE (DLOCAL(01), ENDCOM) 08610005 EQUIVALENCE (DLOCAL(22), EOF1 ) 08620005 EQUIVALENCE (DLOCAL(23), EOF2 ) 08630005 EQUIVALENCE (DLOCAL(20), FILEP1) 08640005 EQUIVALENCE (DLOCAL(21), FILEP2) 08650005 EQUIVALENCE (DLOCAL(27), FNDX ) 08660005 EQUIVALENCE (DLOCAL(08), FOLD ) 08670005 EQUIVALENCE (DLOCAL(06), FS ) 08680005 EQUIVALENCE (DLOCAL(33), FSA ) 08690005 EQUIVALENCE (DLOCAL(29), FSCALE) 08700005 EQUIVALENCE (DLOCAL(28), FSFLAG) 08710005 EQUIVALENCE (DLOCAL(26), IPU ) 08720005 EQUIVALENCE (DLOCAL(02), IVEL ) 08730005 EQUIVALENCE (DLOCAL(03), LOOPX ) 08740005 EQUIVALENCE (DLOCAL(11), LSTCDP) 08750005 EQUIVALENCE (DLOCAL(10), MINFLV) 08760005 EQUIVALENCE (DLOCAL(24), MOVEFG) 08770005 EQUIVALENCE (DLOCAL(40), NCPROC) 08780005 EQUIVALENCE (DLOCAL(17), NEWHD ) 08790005 EQUIVALENCE (DLOCAL(16), NEWTR ) 08800005 EQUIVALENCE (DLOCAL(34), NOVEL ) 08810005 EQUIVALENCE (DLOCAL(25), NOWDS ) 08820005 EQUIVALENCE (DLOCAL(15), NREC ) 08830005 EQUIVALENCE (DLOCAL(32), NSA ) 08840005 EQUIVALENCE (DLOCAL(37), OV2FLG) 08850005 EQUIVALENCE (DLOCAL(13), PTBCDP) 08860005 EQUIVALENCE (DLOCAL(14), PTBFLD) 08870005 EQUIVALENCE (DLOCAL(12), PTBPTR) 08880005 EQUIVALENCE (DLOCAL(41), RMSLIN) 08890005 EQUIVALENCE (DLOCAL(42), RMSMAX) 08900005 EQUIVALENCE (DLOCAL(05), SIZEU ) 08910005 EQUIVALENCE (DLOCAL(07), VELFG ) 08920005 EQUIVALENCE (DLOCAL(45), VELPNO) 08930005 EQUIVALENCE (DLOCAL(36), VTARG ) 08940005 EQUIVALENCE (DLOCAL(18), WKNRC1) 08950005 EQUIVALENCE (DLOCAL(19), WKNRC2) 08960005 EQUIVALENCE (DLOCAL(47), SCLTYP) 08970016 C EQUIVALENCE (DLOCAL(48), ) 08980005 C EQUIVALENCE (DLOCAL(49), ) 08990005 C EQUIVALENCE (DLOCAL(50), ) 09000005 C EQUIVALENCE (DLOCAL(51), ) 09010005 C EQUIVALENCE (DLOCAL(52), ) 09020005 C EQUIVALENCE (DLOCAL(53), ) 09030005 C EQUIVALENCE (DLOCAL(54), ) 09040005 09050005 C 09060005 C NOTE: THE PARAMETER 'XLOCAL' IS DEFINED TO BE ONE GREATER 09070005 C THAN THE LAST DLOCAL SLOT, DEFINED ABOVE. 09080005 C 09090005 EQUIVALENCE (DLOCAL(XLOCAL), PARM) 09100005 C 09110005 C OTHER PARAMETERS 09120005 C 09130005 C JTLIV = 01, THE TICD VALUE FOR LIVE SEISMIC TRACES 09140005 C JTDUM = 02, THE TICD VALUE FOR DEAD TRACES 09150005 C JTVEL = 11, THE TICD VALUE FOR RMS VELOCITY TRACE 09160005 C JTDIP = 33, THE TICD VALUE FOR DIP TRACES 09170005 C MINFLD = 3, THE MINIMUM ACCEPTABLE CDP FOLD 09180005 C 09190005 INTEGER JTLIV, JTDUM, JTVEL, JTDIP, MINFLD 09200005 PARAMETER (JTLIV=1, JTDUM=2, JTVEL=11, JTDIP=33, MINFLD=3) 09210005 C 09220005 C A LIST OF SUBROUTINES CALLED (FOR THE BENEFIT OF THE CRAY): 09230005 C 09240005 EXTERNAL ARMVE, ARSET, CKDD, MCOFGN, DATIME, FGAPRT, FOCDD 09250009 EXTERNAL FOCSD, FOIDSD, FOISSD, FORDSD, FORP, FOWDSD, FOWSSD 09260009 EXTERNAL ISAMAX, SAHCI, SAHCIC, SAHCSC, SAHGRAM, SAMVOT, SAVELC 09270011 EXTERNAL SNRM2, SSCAL, S1CPCH, S1MVCH, UGUWRK, UPAWRK, UPRESM 09280011 EXTERNAL USPHD, USPPLT, USRTHV, USSTHV 09290017 C 09300005 C DATA INITIALIZATION: 09310005 C -------------------- 09320005 C 09330005 C VERSION - THE DATE OF LAST REVISION 09340005 C DC - PARAMETER RECORD KEYS 09350005 C WHEN - USED BY DATE / TIME ROUTINES 09360005 C PDDNAME - DDNAME OF FILE FOR MOVED OUT GATHERS (IBM, ONLY) 09370005 C BW - MAXIMUM INTERPOLATION FREQUENCY AS A FRACTION OF 09380005 C THE NYQUIST RATE FOR EACH OF SIX FILTER LENGTHS 09390005 C FTEXT - THE TYPE ENTITY SCALING IS DERIVED FROM: 09400016 C CDP NUMBER OR HISTOGRAM BIN NUMBER. 09410016 C 09420005 DATA VERSION /'PM 03/28/90'/ 09430028 DATA DC /'PAR', 'H11', 'H12'/ 09440005 DATA WHEN /5*' '/ 09450005 DATA PDDNAME /'MOVEOUT'/ 09460005 DATA BW / 0.12, 0.45, 0.60, 0.70, 0.75, 0.80 / 09470005 DATA FTEXT / 'CDP', 'BIN' / 09480016 C 09490005 C HERE ARE THE IBM SVC99 ERROR CODES FOR 'DATA SET IN USE' AND 09500005 C 'DATA SET ALREADY OPEN' (NOT USED ON THE CRAY): 09510005 C 09520005 C DATA INUSE, OPENED / Z04100000, Z04200000 / 09530005 C 09540005 C DATA INUSE, OPENED / 68157440, 69206016 / 09550005 C 09560005 C 09570005 C 09580005 C***********************************************************************09590005 C*** ****09600005 C*** FIRST PASS INITIALIZATION ****09610005 C*** ****09620005 C***********************************************************************09630005 C 09640005 09650005 C 09660005 C USE 'IPR' FOR THE PRINTER UNIT, AS PER STANDARD SPARC CONVENTION 09670005 C ALWAYS COPY THE GIVEN INPUT TRACE TO ITS RESERVED SAVE AREA. 09680005 C 09690005 IPR = KPPRNT 09700005 CPYFLG = .TRUE. 09710005 C 09720005 C TEST THE SPARC 'FIRST CALL FLAG.' BE SURE TO RESET IT FOR NEXT TIME!09730005 C 09740005 IF( KPFCF .NE. 0 ) THEN 09750005 IF( KPMITF .EQ. 0 ) GOTO 90509760005 KPFCF = 0 09770005 C 09780005 C PRINT HEADING 09790005 C 09800005 CALL USPHD( 2, ACLNAM, KPNA, KPRNO, 0, 0, IPR ) 09810005 C 09820005 C OUTPUT START TIME 09830005 C 09840005 CALL DATIME( WHEN(1), WHEN(4), J ) 09850005 WRITE( IPR, 8000 ) VERSION, KPNA, KPRNO, WHEN 09860005 C 09870005 IF( KPBUGF .GT. 0 ) 09880005 * WRITE( IPR, 8005 ) LCSI, LCPI, LCRL, LCMXFD 09890005 IF( KPBUGF .GE. 2 ) 09900005 * WRITE( IPR, 8015 ) 09910005 C 09920005 C READ THE PARAMETER RECORDS, AND INITIALIZE THE 'DENTRY' HEADERS. 09930005 C 09940005 NREC = 1 09950005 FNDX = 1 09960005 WDSTREAD = LRC 09970005 CALL FORP( KPNA, KPRNO, NREC, WDSTREAD, DENTRY, *900 )09980005 NRPF = (2*MXH)/(LRC - 3) + 1 09990005 NFILL = MMXH - MXH + 1 10000005 FWTR = (LRC - 3)*(NRPF -1) + NFILL 10010005 DO 1087 I=2, NSEIS 10020005 NREC = NRPF*(I - 1) + 1 10030005 WDSTREAD = 2*MXH - (NRPF - 1)*(LRC - 3) + 4 10040005 CALL ARSET(DENTRY(3, I), 2*MMXH + 1, 0.0) 10050005 DO 1077 NWORDS = FWTR, NFILL, 3 - LRC 10060005 CALL FORP(KPNA, KPRNO, NREC, 10070005 * WDSTREAD, DENTRY(NWORDS, I), *900 ) 10080005 CALL ARSET(DENTRY(NWORDS, I), 3, 0.0) 10090005 WDSTREAD = LRC 10100005 1077 NREC = NREC - 2 10110005 1087 CONTINUE 10120005 C 10130005 C RETRIEVE TRACE HEADER REFERENCE VALUES. 10140005 C 10150005 CALL USRTHV( INH, 'THSI ', ISI ) 10160005 CALL USRTHV( INH, 'THCDPN ', ICDPN ) 10170005 CALL USRTHV( INH, 'THTICD ', ITICD ) 10180005 CALL USRTHV( INH, 'THCDPT ', ICDPT ) 10190005 C 10200005 IF(ISI .NE. LCPI*1000) GO TO 910 10210005 FS = 1E6 / ISI 10220005 FSA = STA / LCPI + 1 10230005 NSA = MIN0(ETA / LCPI + 1, NS) - FSA + 1 10240005 C 10250005 C SET THE START OF BLANK COMMON ADDRESSING TO DOUBLE-WORD BOUNDARY. 10260005 C 10270005 KPBEG = KPIUSM + LLOCAL 10280005 KPBEG2 = 2*( KPBEG/2 ) 10290005 IF( KPBEG .EQ. KPBEG2 ) KPBEG = KPBEG + 1 10300005 C 10310005 C DEFINE RESERVED ARRAY POINTERS. 10320005 C 10330005 10340005 C ****************************************************************** 10350005 10360005 C INTERPOLATION COEFFICIENTS 10370005 COEF = KPBEG 10380005 C INDEX OF PRINT BUFFER OF PROCESSED CDP NUMBERS 10390005 PTBCDP = COEF + ILEN*100 10400005 C INDEX OF PRINT BUFFER OF CDP FOLDS 10410005 PTBFLD = PTBCDP + PTBSIZ 10420005 C SAVE AREA FOR FIRST TRACE HEADER OF THE NEXT CDP GATHER 10430005 NEWHD = PTBFLD + PTBSIZ 10440005 C SAVE AREA FOR FIRST TRACE OF THE NEXT CDP GATHER 10450005 NEWTR = NEWHD + THL 10460005 C CURRENT HEADER TEMPLATE 10470005 CURHD = NEWTR + NS 10480005 C SAVE AREA FOR LARGEST ABSOLUTE ATTRIBUTE IN EACH CDP 10490005 CDPSCL = CURHD + THL 10500005 C END OF RESERVED COMMON 10510005 ENDCOM = CDPSCL + NCDPMX 10520005 10530005 C ****************************************************************** 10540005 10550005 C 10560005 C CALCULATE THE DESIRED INCREASE. 10570005 C 10580005 NOWDS = ENDCOM - KPIUSM 10590005 SIZEU = NSA * (ILEN*2 + ISZ) + NS*NUA + 4 + THL + ILEN*2 10600005 SIZEU = MAX0(SIZEU, NZ) 10610005 C 10620005 C RESERVE BLANK COMMON AREA. 10630005 C 10640005 CALL UPRESM( NOWDS ) 10650005 IF( NOWDS .EQ. 0 .OR. KPNUSM .LT. SIZEU ) GO TO 990 10660005 IF( KPBUGF .GT. 0 ) 10670005 * WRITE( IPR, 9900 ) NOWDS, KPNRSM, SIZEU, KPNUSM 10680005 C 10690005 C***********************************************************************10700005 C*** ****10710005 C*** FURTHER PRE-PROCESSING: ****10720005 C*** ****10730005 C***********************************************************************10740005 C 10750005 10760005 C 10770005 C COMPILE THE PARAMETER LIST FOR SUBROUTINE 'SAHCI': 10780005 C 10790005 C NOTE: THE FOLLOWING OPTIONS ARE HANDLED HERE: 10800005 C 10810005 C OPTION 'N' - NMOFLG: NMO STRETCH CORRECTION 10820005 C OPTION 'V' - VFLAG: VERTICAL SPHERICAL DIVERGENCE 10830005 C OPTION 'H' - ISPHFG: HORIZONTAL SPHERICAL DIVERGENCE 10840005 C 10850005 PARM(1) = IHILBT ! HILBERT TRANSFORM LENGTH 10860005 PARM(2) = IAORDR ! "A" STACKING ORDER 10870005 PARM(3) = IBORDR ! "B" STACKING ORDER 10880005 PARM(4) = NMOFLG ! OPTION 'N' FLAG 10890005 PARM(5) = ISPHFG ! OPTION 'H' FLAG 10900005 PARM(6) = VFLAG ! OPTION 'V' FLAG 10910005 PARM(7) = V0 ! V0 FOR OPTION 'H' 10920005 PARM(8) = IBOUT ! PRIMARY & SECONDARY TRACE SELECTION 10930005 PARM(9) = IDSMTH ! PRODUCT TRACE FILTER LENGTH 10940005 PARM(10)= IAFLG ! OPTION 'A' FLAG 10950005 PARM(11)= IBFLG ! OPTION 'B' FLAG 10960005 PARM(12)= TAPER/LCPI ! TAPER LENGTH IN SAMPLES 10970005 PARM(13)= PHROT ! A AND B TRACE ROTATION ANGLE 10980005 PARM(14)= ROTAB*10 ! A-B ANGLE IN TENTHS OF DEGREES 10990005 C 11000005 C IF THE 'A' AND/OR 'B' FLAGS ARE SET, THEN SET THE RESPECTIVE 11010005 C 'PARM' VARIABLE TO THE AGC WINDOW LENGTH IN SAMPLES. 11020005 C A FLAG > 1 MEANS 'SCALE BY ºA OR Bº**2'. 11030005 C 11040005 IF(IAFLG .NE. 0) PARM(10) = MAX0(AGC/LCPI, 1) 11050005 IF(IBFLG .NE. 0) PARM(11) = MAX0(AGC/LCPI, 1) 11060005 IF(IAFLG .GT. 1) PARM(10) = -PARM(10) 11070005 IF(IBFLG .GT. 1) PARM(11) = -PARM(11) 11080005 C 11090005 C SINCE THIS IS A STACKING PROCESS, MOST TRACES ARE NOT PASSED. 11100005 C 'LOOPX' IS A FLAG WHICH MEANS THAT WE ARE BEING REPETITIVELY CALLED 11110005 C WITH KPMOTF=1, TO PASS ON THE ATTRIBUTE TRACES. WE MUST INITIALIZE 11120005 C THIS FLAG WITH A 0. 'ALIM' IS THE SQUARED SINE OF THE MAXIMUM 11130005 C INCIDENCE ANGLE TO PROCESS. 'MOVEFG' DENOTES WHETHER NVEL>0; 11140005 C I.E., WHETHER THE TRACE IS TO BE MOVED OUT. 'MINFLV' IS THE 11150005 C MINIMUM FIRST LIVE VALUE INDEX FOUND SO FAR (INITIALIZED TO 'NS'). 11160005 C 'FSFLAG' IS 0 IF THE THE FIRST TRACE HAS NOT YET BEEN SCANNED 11170005 C FOR MAGNITUDE. SINCE NO ATTRIBUTES HAVE YET BEEN COMPUTED, 11180005 C 'ASCALE' IS INITIALIZED TO 0. 'CDPNDX' POINTS TO FIRST CDP SCALE 11190005 C FACTOR. NO CDPS HAVE BEEN PROCESSED SO FAR. 11200005 C INITIALIZE THE LINE RMS LEVEL: 'RMSLIN'. 11210005 C 11220005 C 11230005 KPDRTF = 0 11240005 KPRTF = KPDRTF 11250005 PTBPTR = 0 11260005 LOOPX = .FALSE. 11270005 MINFLV = NS 11280005 FSFLAG = 0 11290005 ASCALE = 0 11300005 ALIM = SIN(ANGMAX/RADIAN) ** 2 11310005 MOVEFG = NVEL .GT. 0 11320005 NVEL = MAX0(NVEL, 1) 11330005 NOVEL = 0 11340005 CDPNDX = CDPSCL 11350005 NCPROC = 0 11360005 RMSLIN = 0.0 11370005 BIGCDP = 0 11380005 SCLTYP = 1 11390016 IF(IQFLG .EQ. 1 .AND. IZFLG .EQ. 1) SCLTYP = 2 11400016 C 11410005 C IF SCDP=0, RESET IT TO 1. 11420005 C IF ECDP=0, SET IT TO 100000. 11430005 C 11440005 IF(SCDP .EQ. 0) SCDP = 1 11450005 IF(ECDP .EQ. 0) ECDP = 100000 11460005 C 11470005 C ZERO THE MAXIMUM ABSOLUTE ATTRIBUTE ARRAY. 11480005 C PLACE THE FIRST TRACE HEADER INTO ITS RESERVED AREA. 11490005 C 11500005 CALL ARSET(XCOM(CDPSCL), NCDPMX, 0.0) 11510005 CALL ARMVE(INH, ICOM(NEWHD), THL) 11520005 C 11530005 C ALLOCATE AND OPEN WORK FILE #1 FOR TEMPORARY STORAGE OF THIS GATHER. 11540005 C 11550005 WKNRC1 = LCMXFD + 2 11560005 WKRECL = 4*(NS + THL) 11570005 CALL UPAWRK(WKNRC1, WKRECL, 'A', KPWRKS, 11580005 * KPWRKD, DD1, ERR, ERIN) 11590005 IF(ERR .NE. 1) GO TO 93011600005 CJJ CALL FOISSD(KPWRKS, 4*(NS+THL)) 11610031 CALL FOISSD(KPWRKS, 4*(NS+THL), 2) 11620031 FILEP1 = 1 11630005 DO 70 I= 1, WKNRC1 11640005 70 CALL FOWSSD(KPWRKS, FILEP1, INH) 11650005 CALL FOCSD(KPWRKS) 11660005 CALL FOIDSD(KPWRKD, WKRECL) 11670005 11680005 C 11690005 C ALLOCATE AND OPEN WORK FILE #2 FOR ATTRIBUTE STORAGE. 11700005 C 11710005 WKNRC2 = NCDPMX*NVEL*NFILTS 11720005 CALL UPAWRK(WKNRC2, WKRECL, 'B', KPWKS2, KPWKD2, DD2, 11730005 * ERR, ERIN) 11740005 IF(ERR .NE. 1) GO TO 93211750005 CJJ CALL FOISSD(KPWKS2, 4*(NS+THL)) 11760031 CALL FOISSD(KPWKS2, 4*(NS+THL), 2) 11770031 FILEP2 = 1 11780005 DO 80 I= 1, WKNRC2 11790005 80 CALL FOWSSD(KPWKS2, FILEP2, INH) 11800005 CALL FOCSD(KPWKS2) 11810005 CALL FOIDSD(KPWKD2, WKRECL) 11820005 C 11830005 C REWIND THE WORK FILE POINTERS, AND PRINT A MESSAGE. 11840005 C 11850005 WRITE (IPR, 8150) DD1, DD2 11860005 FILEP1 = 1 11870005 FILEP2 = 1 11880005 EOF1 = FILEP1 11890005 EOF2 = FILEP2 11900005 OV2FLG = .FALSE. 11910005 C 11920005 C OPEN THE AUXILIARY PLOTTER FILE, IF DEFINED. 11930005 C 11940005 PDD = PDDNAME 11950005 IF(S1CPCH(SYSTM,1,'CRAY',1,4) .NE. 0) CALL CKDD(PDD) 11960005 IPU = 0 11970005 IF(PDD .EQ. 'PRESENT') THEN 11980005 IPU = IPUNIT 11990005 CALL ARSET(XCOM(ENDCOM), NZ, 0.0) 12000005 OPEN(IPU,FILE=PDDNAME,FORM='UNFORMATTED') 12010005 WRITE (IPU) (XCOM(ENDCOM+I-1), I=1, NZ) 12020005 ENDIF 12030005 C 12040005 C COMPUTE THE INTERPOLATION COEFFICIENTS 12050005 C 12060005 ILEN2 = (ILEN - 1)/2 + 1 12070005 IF( MOVEFG ) 12080005 * CALL MCOFGN(ILEN, BW(ILEN2), RW, G, FF, A, XCOM(COEF)) 12090005 WRITE (IPR, 8200) 12100005 ELSE 12110005 GO TO 120 12120005 ENDIF 12130005 C 12140005 C 12150005 C***********************************************************************12160005 C*** ****12170005 C*** INITIALIZE FOR A NEW CDP! ****12180005 C*** ****12190005 C***********************************************************************12200005 C 12210005 12220005 C 12230005 C SAVE A TEMPLATE OF THE CURRENT CDP TRACE HEADER. 12240005 C NOTE: THERE ARE TWO WAYS TO GET HERE: 12250005 C 12260005 C 1) AFTER HAVING DROPPED DOWN ON THE FIRST CALL; 12270005 C 2) AFTER HAVING PROCESSED A COMPLETE CDP. 12280005 C 12290005 100 CALL ARMVE( ICOM(NEWHD), ICOM(CURHD), THL ) 12300005 C 12310005 C INITIALIZE THE FOLLOWING SAVED VARIABLES: 12320005 C ----------------------------------------- 12330005 C 12340005 C 'LSTCDP' IS UPDATED TO DENOTE THE NEW CDP WE'RE WORKING ON. 12350005 C 'LOOPX' IS A FLAG WHICH MEANS THAT WE ARE BEING REPETITIVELY CALLED 12360005 C WITH KPMOTF=1, TO PASS ON THE ATTRIBUTE TRACES. 12370005 C 'FOLD' DENOTES THE NUMBER OF LIVE IN-RANGE TRACES FOR THIS CDP, 12380005 C INITIALIZED TO -1 SO AS NOT TO INCLUDE THE VELOCITY TRACE. 12390005 C 'FNDX' IS THE INDEX NUMBER OF INVERSION FILTER BEING TRIED. 12400005 C 'ANGBIG' IS THE LARGEST INCIDENCE ANGLE AT THE TARGET ZONE. 12410005 C 'RMSMAX' IS THE MAXIMUM PRIMARY DATA RMS LEVEL FOR ANY VELOCITY 12420005 C FUNCTION, OR ANY INVERSION FILTER FOR THIS CDP. 12430005 C 'VELPNO' IS THE RECORD NUMBER IN SCRATCH FILE #1 FOR THE VELOCITY TRC12440005 C 'DATANO' IS THE RECORD NUMBER FOR THE NEXT DATA TRACE. 12450005 C 12460005 LSTCDP = ICDPN 12470005 VELFG = .FALSE. 12480005 DIPFG = .FALSE. 12490005 LOOPX = .FALSE. 12500005 FNDX = 0 12510005 FOLD = -1 12520005 ANGBIG = 0.0 12530005 RMSMAX = 0.0 12540005 VELPNO = FILEP1 12550005 DATANO = VELPNO + 1 12560005 C 12570005 C COME HERE TO DO A NEW FILTER FUNCTION. 12580005 C 12590005 110 IVEL = 0 12600005 FNDX = FNDX + 1 12610005 C 12620005 C MAKE SURE THAT THE CORRECT FILTER COEFFICIENTS ARE IN MEMORY. 12630005 C 12640005 NRPF = (2*MXH)/(LRC - 3) + 1 ! # RECORDS PER FILTER 12650005 DREC = 2*(FNDX - 1)*NRPF + 2 ! REC NO. OF 1RST FILTER 12660005 IF(NREC - 2*NRPF .NE. DREC) THEN 12670005 NFILL = MMXH - MXH + 1 12680005 FWTR = (LRC-3)*(NRPF -1) + NFILL ! 1RST DENTRY WD TO READ 12690005 DO 115 I = 2, NSEIS 12700005 NREC = DREC + (I-1)*NRPF - 1 ! LAST REC OF THIS FILTER 12710005 WDSTREAD = 2*MXH - (NRPF - 1)*(LRC - 3) + 4 12720005 DO 113 NWORDS = FWTR, NFILL, 3 - LRC 12730005 CALL FORP(KPNA, KPRNO, NREC, 12740005 * WDSTREAD, DENTRY(NWORDS, I), *900 )12750005 CALL ARSET(DENTRY(NWORDS, I), 3, 0.0) 12760005 WDSTREAD = LRC 12770005 113 NREC = NREC - 2 12780005 115 CONTINUE 12790005 NREC = DREC 12800005 ENDIF 12810005 C 12820005 C SAVE LOCAL VARIABLES. 12830005 C 12840005 CALL ARMVE( DLOCAL, ICOM(KPIRSM), LLOCAL ) 12850005 C 12860005 C 12870005 C***********************************************************************12880005 C*** ****12890005 C*** ALL TRACES GO THROUGH THIS PATH. ****12900005 C*** ****12910005 C***********************************************************************12920005 C 12930005 12940005 C 12950005 C RETRIEVE LOCAL VARIABLES. 12960005 C GIVE ME ANOTHER INPUT TRACE, UNLESS OTHERWISE SPECIFIED. 12970005 C 12980005 C WE EITHER DROP DOWN TO THIS POINT AFTER HAVING INITIALIZED FOR 12990005 C A NEW CDP, OR JUMP DIRECTLY DOWN FROM THE ENTRY POINT FOR 13000005 C ALL CALLS, EXCEPT THE FIRST ONE. 13010005 C 13020005 120 CALL ARMVE( ICOM( KPIRSM ), DLOCAL, LLOCAL ) 13030005 KPMOTF = 0 13040005 IF (LOOPX) GO TO 60013050005 IF (IVEL .EQ. 0 .AND. FNDX .EQ. 1) THEN 13060005 C 13070005 C WE'RE STILL COPYING THE CDP GATHER INTO THE SCRATCH FILE, 13080005 C BUT FIRST COPY THE INPUT TRACE TO RESERVED COMMON. 13090005 C 'CPYFLG' FALSE MEANS 'USE THE TRACE THAT IS ALREADY THERE.' 13100005 C 13110005 IF(CPYFLG) THEN 13120005 CALL ARMVE(INH, ICOM(NEWHD), THL) 13130005 CALL ARMVE(INTR, XCOM(NEWTR), NS) 13140005 ENDIF 13150005 C 13160005 C GET SOME HEADER VALUES. 13170005 C 13180005 CALL USRTHV( ICOM(NEWHD), 'THCDPN ', ICDPN ) 13190005 CALL USRTHV( ICOM(NEWHD), 'THCDPT ', ICDPT ) 13200005 CALL USRTHV( ICOM(NEWHD), 'THTICD ', ITICD ) 13210005 C 13220005 C IF THIS TRACE BELONGS TO A DIFFERENT CDP, THEN BEGIN PROCESSING 13230005 C THE LAST CDP. OTHERWISE, CONTINUE COPYING IT TO SCRATCH FILE #1. 13240005 C 13250005 IF (LSTCDP .EQ. ICDPN) GO TO 20013260005 ENDIF 13270005 C 13280005 C***********************************************************************13290005 C*** ****13300005 C*** START A NEW VELOCITY FUNCTION. ****13310005 C*** ****13320005 C***********************************************************************13330005 C 13340005 IVEL = IVEL + 1 13350005 C 13360005 C REWIND SCRATCH FILE #1. CDPS OUTSIDE THE PROCESSING RANGE AND 13370005 C CDPS FOR WHICH THERE IS NO VELOCITY FUNCTION ARE NOT TO BE PROCESSED.13380005 C 13390005 FILEP1 = 1 13400005 IF(LSTCDP .LT. SCDP .OR. LSTCDP .GT. ECDP) GO TO 550 13410005 C 13420005 C SET THE START OF BLANK COMMON ADDRESSING TO DOUBLE-WORD BOUNDARY. 13430005 C 13440005 KPBEG = KPIUSM 13450005 KPBEG2 = 2*( KPBEG/2 ) 13460005 IF( KPBEG .EQ. KPBEG2 ) KPBEG = KPBEG + 1 13470005 C 13480005 C ESTABLISH POINTERS TO UNRESERVED COMMON. 13490005 C 13500005 C NOTE: THE ACCUMULATION ARRAYS, 'S', AND INTERPOLATION ARRAYS, 13510005 C 'TRCOEF', NEED ONLY BE AS LARGE AS THE OUTPUT RECORD LENGTH. 13520005 C THE SLOTH ARRAYS, ON THE OTHER HAND, MUST SPAN THE 13530005 C ENTIRE INPUT RECORD LENGTH, PLUS AN EXTRA SAMPLE AT EACH END. 13540005 C 'SCRATCH' MUST LIE ON A DOUBLE WORD BOUNDARY. 13550005 C 13560005 SCRATCH = KPBEG 13570005 S = SCRATCH + 2*NS + ILEN 13580005 SLOTH = S + NSA*ISZ 13590005 SLOTHI = SLOTH + NS + 2 13600005 DIPANG = SLOTHI + NS + 2 13610005 TRCOEF = DIPANG + NS 13620005 HEAD = TRCOEF + ILEN*NSA*2 13630005 TRSAVE = HEAD + THL 13640005 INFSA = TRSAVE + FSA - 1 13650005 IF( SIZCOM .LT. TRSAVE + NS + ILEN ) GO TO 990 13660005 C 13670005 C AT THIS POINT, ASSUME THAT THE NEXT TRACE PASSED WILL BE A DUMMY. 13680005 C ZERO UNRESERVED MEMORY. COPY THE CURRENT HEADER TEMPLATE TO 13690005 C ITS SCRATCH AREA, IN CASE IT'S NEEDED. ANY MORE VELOCITIES TO TRY? 13700005 C 13710005 ITICD = JTDUM 13720005 CALL ARSET(OTR, NS, 0.0) 13730005 CALL ARSET(XCOM(KPIUSM), SIZEU, 0.0) 13740005 CALL ARMVE(ICOM(CURHD), ICOM(HEAD), THL) 13750005 IF(IVEL-NVEL) 300,300,500 13760005 C 13770005 C***********************************************************************13780005 C*** ****13790005 C*** COPY THE CDP GATHER TO SCRATCH FILE #1. ****13800005 C*** ****13810005 C***********************************************************************13820005 13830005 C 13840005 C SELECT ONLY THOSE TRACES THAT ARE WITHIN THE PROCESSING RANGE. 13850005 C 13860005 200 IF(ICDPN .LT. SCDP .OR. ICDPN .GT. ECDP) GO TO 25013870005 C 13880005 C LIVE TRACES ARE ACCEPTED ONLY AFTER A VALID VELOCITY TRACE. 13890005 C ACCEPT ALL VELOCITY TRACES. LET SUBSEQUENT ONES OVERRIDE PREVIOUS 13900005 C ONES. ALL OTHER TRACES ARE REJECTED. 13910005 C REMEMBER THE GIVEN VELOCITY AT THE TARGET ZONE. 13920005 C 13930005 IF (ITICD .EQ. JTVEL) THEN 13940005 VTARG = XCOM(NEWTR + MIN0(INT(TARGET*FS*1E-3)+1, NS) - 1) 13950005 FILEP1 = VELPNO 13960005 VELFG = .TRUE. 13970005 ELSE IF (ITICD .EQ. JTDIP) THEN 13980005 DIPFG = .TRUE. 13990005 DATANO = FILEP1 + 2 14000005 ELSE IF (ITICD .EQ. JTLIV .AND. VELFG) THEN 14010005 FILEP1 = DATANO 14020005 ELSE 14030005 GO TO 25014040005 ENDIF 14050005 C 14060005 C COPY THIS TRACE TO SCRATCH FILE #1, IF SELECTED. 14070005 C INCREMENT FILEP1, EOF1, AND THE CDP FOLD COUNTER. 14080005 C 14090005 IF(FILEP1 .GT. WKNRC1) GO TO 94514100005 IF(ITICD .EQ. JTVEL .OR. ITICD .EQ. JTDIP .OR. ICDPT .GE. MINTR 14110005 * .AND. ICDPT .LE. MAXTR) THEN 14120005 CALL FOWDSD(KPWRKD, FILEP1, ICOM(NEWHD)) 14130005 IF(ITICD .EQ. JTLIV) DATANO = FILEP1 14140005 FOLD = FOLD + 1 14150005 EOF1 = FILEP1 14160005 ENDIF 14170005 C 14180005 C---------------------------------------------------------------------- 14190005 C 14200005 C GENERAL RETURN EPILOG: 14210005 C 14220005 C SAVE LOCAL VARIABLES 14230005 C 14240005 250 CALL ARMVE( DLOCAL, ICOM(KPIRSM), LLOCAL ) 14250005 IF(KPBUGF .GE. 3) WRITE (IPR,9800) KPRTF, KPDRTF, KPMOTF, 14260005 * KPLOTF, KPMITF 14270005 C 14280005 C THE ONLY WAY OUT OF THIS MAZE IS THE FOLLOWING: 14290005 C 14300005 RETURN 14310005 C 14320005 C***********************************************************************14330005 C*** ****14340005 C*** BEGIN THE CDP PLAYBACK AND COLLECTION PROCESS ****14350005 C*** ****14360005 C***********************************************************************14370005 C 14380005 14390005 C 14400005 C IN THE CASE OF ZERO FOLD, SIMPLY PASS A DUMMY TRACE. 14410005 C READ A TRACE FROM SCRATCH FILE #1. (FILEP1 IS AUTOMATICALLY BUMPED.)14420005 C 14430005 300 IF(FOLD .LT. MINFLD) GO TO 45014440005 IF(FILEP1 .GE. EOF1) GO TO 40014450005 CALL FORDSD(KPWRKD, FILEP1, ICOM(HEAD)) 14460005 C 14470005 C RECOVER SOME TRACE HEADERS 14480005 C 14490005 CALL USRTHV(ICOM(HEAD), 'THTICD ', ITICD) 14500005 CALL USRTHV(ICOM(HEAD), 'THDRT ', IBULK) 14510005 CALL USRTHV(ICOM(HEAD), 'THFLV ', IFLV) 14520005 CALL USRTHV(ICOM(HEAD), 'THXDST ', IXOFF) 14530005 CALL USRTHV(ICOM(HEAD), 'THCDPT ', ICDPT) 14540005 CALL USRTHV(ICOM(HEAD), 'THVPMT ', ITP) 14550005 CALL USRTHV(ICOM(HEAD), 'THNTDP ', NTDP) 14560005 CALL USRTHV(ICOM(HEAD), 'THSPDP ', SPDP) 14570005 CALL USRTHV(ICOM(HEAD), 'THNTCR ', NTCR) 14580005 CALL USRTHV(ICOM(HEAD), 'THOT ', ILLV) 14590005 C 14600005 C PRINT THESE, IF THE DEBUG LEVEL >= 2 14610005 C 14620005 IF(KPBUGF .GE. 2) 14630005 * WRITE (IPR, 8250) KPRNO, ITICD, IFLV, IXOFF, ICDPT, ITP, 14640005 * NTDP, INT(SPDP), SPDP, NTCR, ILLV 14650005 C 14660005 C PERFORM SOME SIMPLE TRANSFORMATIONS OF THE TRACE HEADERS. 14670005 C 14680005 TSAMP = 1.0 / FS 14690005 T0 = IBULK * 1E-3 14700005 T0S = T0 + STA * 1E-3 14710005 LSA = MIN0(FSA + NSA - 1, NS) 14720005 XOFF = IXOFF 14730005 IFLV = MAX0(IFLV, 1) 14740005 ANGLE = RADIAN * ATAN(1E3*XOFF/VTARG/(TARGET+IBULK)) 14750005 C 14760005 C FOR TAU-P DATA (OPTION 'T'), 'XOFF' REPRESENTS 'P'. 14770005 C COMPUTE THE PHYSICAL APERTURE TO BE USED IN THE ANALYSIS. 14780005 C 14790005 IF(TPFLG .EQ. 1) THEN 14800005 XOFF = ITP * 1E-6 14810005 ANGLE = RADIAN * ASIN(AMIN1(XOFF*VTARG, 0.999)) 14820005 PHYSAP(1) = 1E-2 * TPAPT * SPDP * NTCR 14830005 PHYSAP(2) = 1E-2 * TPAPT * SPDP * NTDP 14840005 IF (ILLV .EQ. 0) IFLV = 1 14850005 ENDIF 14860005 ANGBIG = AMAX1(ANGBIG, ABS(ANGLE)) 14870005 C 14880005 C IF THIS TRACE IS THE VELOCITY FUNCTION, CONVERT IT TO 14890005 C STACKING SLOTH (V**-2) AND INTERVAL SLOTH IF OPTION 'I' IS GIVEN. 14900005 C OVERRIDE THE STACKING SLOTH WITH THAT AT THE TARGET ZONE IF 14910005 C OPTION 'O' IS GIVEN. LET THIS VELOCITY TRACE OVERRIDE ANY PREVIOUS 14920005 C VELOCITY TRACE(S) FOR THIS CDP GATHER, THUS UTILIZING ONLY THE 14930005 C LAST 'NMOC VFU' WHICH WAS APPLIED. 14940005 C 14950005 IF(ITICD .EQ. JTVEL) THEN 14960005 VINC = (IVEL - IGVEL)*VELINC 14970005 CALL SAVELC(XCOM(TRSAVE), XCOM(SLOTH), XCOM(SLOTHI), 14980005 * NS, IVSMTH, NINT(VFLEN(FNDX)), T0, VINC, TSAMP, 14990005 * OVRFLG, TARGET, IER) 15000005 IF(IER .GT. 0) GO TO 98015010005 GO TO 30015020005 ENDIF 15030005 C 15040005 C IF THIS TRACE IS THE DIP ANGLE TRACE, SAVE IT AWAY INTO ITS 15050005 C SCRATCH COMMON SLOT. 15060005 C 15070005 IF(ITICD .EQ. JTDIP) THEN 15080005 CALL ARMVE(XCOM(TRSAVE), XCOM(DIPANG), NS) 15090005 GO TO 30015100005 ENDIF 15110005 C 15120005 C SCALE THIS TRACE, BASED UPON THE FIRST LIVE TRACE, UNLESS 15130005 C OPTION 'F' IS SPECIFIED. 15140005 C 15150005 IF(IFFFLG .EQ. 1) 15160005 * CALL SAHCSC(XCOM(TRSAVE), NS, IFLV, FSCALE, FSFLAG) 15170005 C 15180005 C NMO-CORRECT THE DATA, IF NECESSARY. SIMPLY COPY IT, IF NOT. 15190005 C 15200005 FSMP = MAX0(FSA, IFLV) 15210005 LSMP = LSA 15220005 IF(MOVEFG) THEN 15230005 CALL ARSET(XCOM(TRSAVE - ILEN), ILEN, 0.0) 15240005 CALL ARSET(XCOM(TRSAVE + NS ), ILEN, 0.0) 15250005 CALL SAMVOT(XCOM(TRSAVE- ILEN), XCOM(SLOTH), XCOM(COEF), 15260005 * OTR, XCOM(TRCOEF), XCOM(SCRATCH), NS, ILEN, 15270005 * FSA, LSA, XOFF, IFLV, T0, TSAMP, TPFLG, FSMP, LSMP) 15280005 ELSE 15290005 CALL ARMVE(XCOM(INFSA), OTR(FSA), NSA) 15300005 ENDIF 15310005 C 15320005 C NOW COLLECT THE RUNNING SUMS IN THE 'S' ARRAY. 15330005 C 15340005 MINFLV = MIN0(MINFLV, IFLV) 15350005 CALL SAHCIC(XCOM(S), OTR, XCOM(SLOTH), XCOM(DIPANG), 15360005 * XCOM(SCRATCH), FSMP, LSMP, FSA, LSA, T0, TSAMP, XOFF, 15370005 * ALIM, TPFLG, PHYSAP) 15380005 C 15390005 C COPY THE MOVED OUT TRACE TO 'PDDNAME', IF DEFINED. 15400005 C 15410005 IF(IPU .GT. 0) WRITE (IPU) (ICOM(HEAD+I-1), I=1, THL), OTR 15420005 GO TO 300 15430005 C 15440005 C***********************************************************************15450005 C*** ****15460005 C*** COLLECTION IS COMPLETE, DO THE AVO ANALYSIS . . . ****15470005 C*** ****15480005 C***********************************************************************15490005 C 15500005 15510005 400 CALL ARSET(XCOM(TRSAVE), NS, 0.0) 15520005 CALL ARSET(OTR, NS, 0.0) 15530005 CALL SAHCI(XCOM(S), H1, H2, XCOM(SLOTH+FSA-1), XCOM(SLOTHI+FSA-1),15540005 * PARM, OTR(FSA), XCOM(INFSA), NSA, MMXH, NPARM, NSA, 15550005 * LFLTR(FNDX), T0S, TSAMP, AVOPCT) 15560005 C 15570005 C SET THE ATTRIBUTE TICD, AS PRESCRIBED BY THE PREP STEP. 15580005 C GET THIS CDP'S SCALE FACTOR. 15590005 C 15600005 ITICD = TIDCB 15610005 CSCALE = XCOM(CDPNDX) 15620005 C 15630005 C SCALING FOR OPTION 'Q': 15640005 C 15650005 C UPDATE 'CSCALE', THE LARGEST ATTRIBUTE MAGNITUDE FOR THIS CDP. 15660005 C UPDATE 'ASCALE', THE LARGEST ATTRIBUTE MAGNITUDE OF ALL CDPS. 15670005 C 15680005 IF(IQFLG .NE. 0) THEN 15690005 CSCALE = AMAX1(CSCALE, 15700005 * ABS(XCOM(ISAMAX(NSA, XCOM(INFSA), 1)+INFSA-1))) 15710005 IF(CSCALE .GT. ASCALE) THEN 15720005 ASCALE = CSCALE 15730005 BIGCDP = LSTCDP 15740005 ENDIF 15750005 C 15760005 C SCALING WITHOUT OPTION 'Q': 15770005 C 15780005 C 'CSCALE' IS NOW THE LARGEST RMS LEVEL FOR THIS CDP. 15790005 C 'ASCALE' IS THE SUM OF CSCALES FOR ALL CDPS PASSED SO FAR. 15800005 C 15810005 ELSE 15820005 CSCALE = AMAX1(CSCALE, SNRM2(NSA, XCOM(INFSA), 1)/NSA) 15830005 ENDIF 15840005 C 15850005 C STORE THE ATTRIBUTE SCALE FOR THIS CDP, 15860005 C AND COMPUTE THE MAXIMUM RMS LEVEL OF THE PRIMARY DATA. 15870005 C 15880005 XCOM(CDPNDX) = CSCALE 15890005 RMSMAX = AMAX1(RMSMAX, SNRM2(NSA, OTR(FSA), 1)/NSA) 15900005 C 15910005 C FIX UP THE HEADERS OF THE ATTRIBUTE TRACES. 15920005 C ALSO RENUMBER THE CDP NUMBERS FOR 'QULR' FOR OPTION 'Q', IF 15930005 C MORE THAN 1 VELOCITY FUNCTION OR INVERSION FILTER WAS USED. 15940005 C 15950005 450 CALL USRTHV(ICOM(HEAD), 'THDPNS ', SHOT) 15960005 CALL USSTHV(ICOM(HEAD), 'THSSP ', SHOT) 15970005 CALL USSTHV(ICOM(HEAD), 'THNHST ', FOLD) 15980005 CALL USSTHV(ICOM(HEAD), 'THCDPT ', IVEL) 15990005 CALL USSTHV(ICOM(HEAD), 'THFN ', FNDX) 16000005 CALL USSTHV(ICOM(HEAD), 'THTICD ', ITICD) 16010005 CALL USSTHV(ICOM(HEAD), 'THFLV ', MINFLV) 16020005 CALL USSTHV(ICOM(HEAD), 'THCDPL ', NCPROC+1) 16030005 CALL USSTHV(ICOM(HEAD), 'THSEQL ', FILEP2) 16040005 CALL USSTHV(ICOM(HEAD), 'THWV ', V0) 16050005 CALL USSTHV(ICOM(HEAD), 'THNMF ', 1) 16060005 IF(IQFLG .NE. 0 .AND. NVEL*NFILTS .GT. 1) 16070005 * CALL USSTHV(ICOM(HEAD), 'THCDPN ', FILEP2) 16080005 C 16090005 C FIX UP THE HEADERS OF THE PRIMARY DATA TRACES. 16100005 C 16110005 CALL ARMVE (ICOM(HEAD), OH, THL) 16120005 IF(ITICD .NE. JTDUM) ITICD = TIDCA 16130005 CALL USSTHV(OH, 'THTICD ', ITICD) 16140005 C 16150005 C COPY THE ATTRIBUTE HEADER & TRACE TO SCRATCH FILE #2. 16160005 C 16170005 IF(FILEP2 .GT. WKNRC2) GO TO 95016180005 CALL FOWDSD(KPWKD2, FILEP2, ICOM(HEAD)) 16190005 EOF2 = FILEP2 16200005 C 16210005 C PASS THE PRIMARY TRACE, AND COME BACK WITHOUT GIVING ME MORE INPUT. 16220005 C 16230005 480 KPRTF = 1 16240005 KPMOTF = 1 16250005 GO TO 25016260005 16270005 C 16280005 C***********************************************************************16290005 C*** ****16300005 C*** WE'RE NOW DONE WITH THIS CDP. ****16310005 C*** ****16320005 C***********************************************************************16330005 C 16340005 16350005 C 16360005 C CHECK TO SEE WHETHER THERE IS ANOTHER INVERSE FILTER TO TRY. 16370005 C 16380005 500 IF(FNDX .LT. NFILTS) GO TO 11016390005 C 16400005 C UPDATE 'ASCALE' IF OPTION 'Q' IS NOT SPECIFIED. 16410005 C ALSO UPDATE THE AVERAGE MAXIMUM RMS LEVEL FOR THE ENTIRE LINE. 16420005 C BUMP THE COUNT OF CDPS PROCESSED SO FAR. 16430005 C 16440005 IF(IQFLG .EQ. 0) ASCALE = ASCALE + XCOM(CDPNDX) 16450005 RMSLIN = RMSLIN + RMSMAX 16460005 CDPNDX = MIN0(CDPNDX + 1, CDPSCL + NCDPMX) 16470005 NCPROC = NCPROC + 1 16480005 C 16490005 C ADD THIS CDP TO THE LIST OF CDPS PROCESSED. 16500005 C INCLUDE THE MAXIMUM INCIDENCE ANGLE AT THE TARGET ZONE. 16510005 C 16520005 ICOM(PTBCDP+PTBPTR) = LSTCDP 16530005 ICOM(PTBFLD+PTBPTR) = AMIN1(ANGBIG, FLOAT(ANGMAX)) 16540005 IF( PTBPTR .GE. PTBSIZ-1 ) THEN 16550005 CALL FGAPRT(IPR, ICOM(PTBCDP), ICOM(PTBFLD), PTBSIZ) 16560005 PTBPTR = -1 16570005 ENDIF 16580005 PTBPTR = PTBPTR + 1 16590005 C 16600005 C CHECK TO MAKE SURE THERE WAS A VELOCITY FUNCTION FOR THIS CDP. 16610005 C 16620005 IF(.NOT. VELFG) THEN 16630005 NOVEL = NOVEL + 1 16640005 KPWARN = -1 16650005 ENDIF 16660005 C 16670005 C IF THIS IS NOT THE FINAL CURTAIN CALL, GET THE NEXT CDP NUMBER, 16680005 C AND BEGIN COPYING IT TO SCRATCH FILE #1. RESET 'CPYFLG', TO 16690005 C INDICATE THAT THE FIRST TRACE OF THE NEXT CDP IS ALREADY IN 16700005 C PLACE IN THE RESERVED AREA. 16710005 C 16720005 550 IF(KPMITF .NE. 0) THEN 16730005 CALL USRTHV(ICOM(NEWHD), 'THCDPN ', ICDPN) 16740005 CPYFLG = .FALSE. 16750005 GO TO 10016760005 ENDIF 16770005 C 16780005 C***********************************************************************16790005 C*** ****16800005 C*** AT THIS POINT, WE'VE PROCESSED THE ENTIRE LINE. ****16810005 C*** ****16820005 C***********************************************************************16830005 C 16840005 16850005 C 16860009 C NOTE: THE ONLY WAYS WE CAN GET HERE ARE: 16870009 C 1) WE DROP DOWN, NOTING THAT KPMITF = 0; 16880009 C 2) WE RUN OUT OF ROOM ON SCRATCH FILE #2. 16890009 C 16900026 C FROM HERE ON WE'RE DONE WITH THE INPUT SEISMIC DATA, AND WE'RE ONLY 16910026 C GOING TO BE DEALING WITH THE ATTRIBUTES IN SCRATCH FILE #2. 16920026 C SET THE 'LOOPX' FLAG TO INDICATE THIS. REWIND SCRATCH FILE #2. 16930026 C IF NONE OF THE CDPS HAD VELOCITY FUNCTIONS, ABORT NOW! 16940028 C 16950009 580 LOOPX = .TRUE. 16960026 FILEP2 = 1 16970026 IF(NOVEL .GE. NCPROC) GO TO 92016980028 C 16990026 C FLUSH THE CDP PRINT BUFFER. 17000016 C IF WE'RE SCALING BY RMS LEVEL (NO 'Q' OPTION), DIVIDE THE SUM 17010005 C OF PRIMARY CDP RMS LEVELS BY THE NUMBER OF PRIMARY CDPS. 17020005 C IF WE'RE SCALING BY HISTOGRAM ('Q' BUT NO 'Z'), SET 'ASCALE' 17030009 C TO BE THE ATTRIBUTE LEVEL WHICH EXCLUDES 'USCALE'-% OF THE VALUES.17040025 C 17050009 CALL FGAPRT(IPR, ICOM(PTBCDP), ICOM(PTBFLD), PTBPTR) 17060026 IF(NCPROC .GT. 0) THEN 17070016 RMSLIN = RMSLIN / NCPROC 17080009 IF(IQFLG .EQ. 0) ASCALE = ASCALE / NCPROC 17090016 IF(SCLTYP .EQ. 2 .AND. USCALE .GT. 0) THEN 17100016 SCRATCH = KPBEG ! START OF HISTOGRAM ARRAY 17110009 IF(SIZCOM .LT. SCRATCH + 2*HSTSZE+1) GO TO 99017120020 C 17130016 C COMPUTE THE HISTOGRAM. 17140026 C 'BIGCDP' <-- THE BIN NUMBER THAT SCALING IS BASED UPON. 17150016 C 17160016 17170020 CALL SAHGRAM(ICOM(SCRATCH), XCOM(SCRATCH), HSTSZE, 17180016 * KPWKD2, EOF2, OH, OTR, THL, NS, USCALE, ASCALE, 17190016 * BIGCDP) 17200016 IF(BIGCDP .GT. 0) THEN 17210022 WRITE (IPR, 8340) -HSTSZE, HSTSZE, BIGCDP, HSTMAX 17220026 IF (NHPLOT) 600, 590, 592 17230026 C 17240026 C PLOT THE HISTOGRAM, IF DESIRED. 17250026 C 17260026 590 NHPLOT = BIGCDP + 20 17270026 592 NHPLOT = MIN0(NHPLOT, HSTSZE) 17280026 HNDX = SCRATCH + HSTSZE - NHPLOT 17290026 NHPTS = 2*NHPLOT + 1 17300022 CALL USPPLT(XCOM(HNDX), NHPTS, 1, NHPTS, -NHPLOT, 17310022 * 1, 0, 1, IPR) 17320022 ELSE 17330022 WRITE (IPR, 9150) 17340022 KPWARN = -1 17350022 ENDIF 17360024 ENDIF 17370009 ENDIF 17380005 17390005 C 17400005 C SET THE DESIRED ATTRIBUTE LEVEL TO BE 'USCALE' ONLY IF OPTION 'Q' 17410005 C WAS SPECIFIED, BUT OPTION 'Z' WAS NOT. FOR HISTOGRAM SCALING, 17420009 C SET 'USCALE' = 'HSTMAX'. OTHERWISE, SET THE DESIRED LEVEL TO BE 17430009 C 'USCALE' TIMES THE AVERAGE RMS LEVEL OF THE PRIMARY DATA. 17440009 C 17450005 600 DESIRE = USCALE 17460005 IF(IQFLG .EQ. 0) DESIRE = USCALE * RMSLIN 17470005 IF(SCLTYP .EQ. 2) DESIRE = HSTMAX 17480016 CSCALE = -USCALE 17490005 C 17500005 C CONTINUE PASSING TRACES FROM SCRATCH FILE #2, SCALING BY 'CSCALE', 17510005 C UNTIL SCRATCH FILE #2 IS EXHAUSTED. 17520005 C 17530005 IF(FILEP2 .LT. EOF2) THEN 17540005 CALL FORDSD(KPWKD2, FILEP2, OH) 17550005 C 17560005 C IF 'USCALE' IS GIVEN TO BE NEGATIVE, FORGET ABOUT THE 17570005 C DESIRED LEVEL, AND SIMPLY SCALE THE ATTRIBUTES BY -USCALE. 17580005 C 17590005 IF(CSCALE .LT. 0.0) THEN 17600005 IF(ASCALE .GT. 0.0) CSCALE = DESIRE / ASCALE 17610005 CALL USRTHV(OH, 'THCDPL ', CDPNDX) 17620005 C 17630005 C IF OPTION 'S' IS SPECIFIED, EACH CDP GETS ITS OWN SCALE FACTOR. 17640005 C 17650005 CDPNDX = CDPSCL + MIN0(CDPNDX, NCDPMX) - 1 17660005 TEMP = XCOM(CDPNDX) 17670005 IF(SCLFLG .NE. 0 .AND. TEMP .GT. 0.0) 17680005 * CSCALE = DESIRE / TEMP 17690005 ENDIF 17700005 C 17710005 C DO THE FINAL ATTRIBUTE SCALING. 17720005 C 17730005 CALL SSCAL(NSA, CSCALE, OTR(FSA), 1) 17740005 GO TO 48017750005 ENDIF 17760005 C 17770005 C***********************************************************************17780005 C*** ****17790005 C*** FINAL EXIT ****17800005 C*** ****17810005 C***********************************************************************17820005 C 17830005 17840005 C 17850005 C IF ANY CDPS FAILED TO HAVE VELOCITY FUNCTIONS, THEN SO WARN THE USER.17860005 C PRINT THE ATRRIBUTE SCALE FACTOR NOW, UNLESS A HISTOGRAM IS COMING. 17870016 C 17880005 IF(NOVEL .GT. 0) WRITE (IPR, 9020) NOVEL 17890005 CSCALE = 0.0 17900016 IF(ASCALE .GT. 0.0) CSCALE = DESIRE / ASCALE 17910016 IF(CSCALE .GT. 0.0 .AND. BIGCDP .EQ. 0) 17920016 * WRITE (IPR, 8300) CSCALE 17930018 IF(CSCALE .GT. 0.0 .AND. BIGCDP .NE. 0) 17940016 * WRITE (IPR, 8320) CSCALE, FTEXT(SCLTYP), BIGCDP 17950016 C 17960005 C CLOSE AND FREE THE WORK FILES. 17970005 C 17980005 850 CALL FOCDD( KPWRKD ) 17990005 CALL FOCDD( KPWKD2 ) 18000005 CALL UGUWRK(KPWRKS, KPWRKD, ERR, ERIN) 18010005 IF (ERR .NE. 1) GO TO 96018020005 860 CALL UGUWRK(KPWKS2, KPWKD2, ERR, ERIN) 18030005 IF (ERR .NE. 1) GO TO 97018040005 IF(IPU .GT. 0) CLOSE (IPU) 18050005 C 18060005 C PRINT A FINAL FAREWELL MESSAGE. 18070005 C 18080005 870 CALL DATIME( WHEN(1), WHEN(4), J ) 18090005 WRITE( IPR, 8900 ) KPNA, KPRNO, WHEN, NCPROC 18100005 C 18110005 C DON'T PASS THE TRACE, AND DON'T EVER COME BACK. 18120005 C ABANDON, IF WORK FILE #2 OVERFLOWED. 18130005 C 18140005 IF(OV2FLG) KPRTF = -1 18150005 IF(KPRTF .GT. 0) KPRTF = 0 18160005 KPLOTF = 0 18170005 KPMOTF = 0 18180005 GO TO 25018190005 C 18200005 C***********************************************************************18210005 C*** ****18220005 C*** ERROR DIAGNOSTICS ****18230005 C*** ****18240005 C***********************************************************************18250005 C 18260005 C AVEL SEISPARM ERROR 18270005 C 18280005 900 WRITE( IPR, 9000 ) KPNA, KPRNO, NREC, LRC 18290005 GO TO 91518300005 C 18310005 C NO INPUT DATA 18320005 C 18330005 905 WRITE( IPR, 9050 ) KPFCF, KPMITF 18340005 GO TO 91518350005 C 18360005 C SAMPLING INTERVAL MISMATCH 18370005 C 18380005 910 WRITE( IPR, 9100 ) ISI, LCPI 18390005 915 KPRTF = -1 18400005 GO TO 85018410005 C 18420005 C NO VELOCITY FUNCTIONS 18430005 C 18440005 920 WRITE( IPR, 9070 ) 18450005 GO TO 91518460005 C 18470005 C WORK FILE ALLOCATION ERROR 18480005 C 18490005 930 CONTINUE 18500005 DDNAME = DD1 18510005 WKNREC = WKNRC1 18520005 GO TO 93518530005 932 DDNAME = DD2 18540005 WKNREC = WKNRC2 18550005 935 WRITE( IPR, 9030 ) DDNAME, WKNREC, WKRECL, ERR, ERIN 18560005 GO TO 91518570005 C 18580005 C OUT OF ROOM ON SCRATCH FILE #1 18590005 C 18600005 945 WRITE (IPR, 9045) 1, WKNRC1 18610005 WRITE (IPR, 9046) 18620005 GO TO 91518630005 C 18640005 C OUT OF ROOM ON SCRATCH FILE #2 18650005 C 18660005 950 WRITE (IPR, 9045) 2, WKNRC2 18670005 WRITE (IPR, 9047) 18680005 OV2FLG = .TRUE. 18690005 GO TO 58018700005 C 18710005 C WORK FILE UNALLOCATION ERROR 18720005 C 18730005 960 WRITE( IPR, 9060 ) DD1, ERR, ERIN 18740005 GO TO 86018750005 970 WRITE( IPR, 9060 ) DD2, ERR, ERIN 18760005 GO TO 87018770005 C 18780005 C BAD VELOCITY FOUND 18790005 C 18800005 980 WRITE( IPR, 9080 ) LSTCDP, IER, INTR(IER) 18810005 GO TO 915 18820005 C 18830005 C REQUESTED MEMORY UNAVAILABLE 18840005 C 18850005 990 WRITE( IPR, 9900 ) NOWDS, KPNRSM, SIZEU, KPNUSM 18860005 GO TO 91518870005 C 18880005 C***********************************************************************18890005 C*** ****18900005 C*** FORMAT STATEMENTS ****18910005 C*** ****18920005 C***********************************************************************18930005 C 18940005 C REGULAR AND DEBUG OUTPUT 18950005 C 18960005 8000 FORMAT('0 ',A,' VERSION OF ',A4,I1,' STARTS AT TIME: ', 18970005 * 5A4//) 18980005 C 18990005 8015 FORMAT('0 ', ' TICD DRT FLV XDST CDPT', 19000005 * ' VPMT NTDP SPDP NTRC') 19010005 C 19020005 8005 FORMAT(' LINE CARD PARAMETERS'/ 19030005 * ' --------------------'/ 19040005 * ' SAMPLE INTERVAL (MS) (LCSI) = ',I5/ 19050005 * ' PROCESSING INTERVAL (MS) (LCPI) = ',I5/ 19060005 * ' RECORD LENGTH (LCRL) = ',I5/ 19070005 * ' MAXIMUM FOLD (LCMXFD) = ',I5//) 19080005 C 19090005 8150 FORMAT(' WORK FILES SUCCESSFULLY ALLOCATED: ', 2A20) 19100005 C 19110005 8200 FORMAT( /' *** CDPS PROCESSED (MAXIMUM INCIDENCE ANGLE', 19120005 * ' AT TARGET ZONE): ***'/T15/) 19130005 C 19140005 8250 FORMAT( 10I9 ) 19150005 * 19160005 C 19170005 8300 FORMAT(/// ' *** ATTRIBUTE SCALE FACTOR = ', G20.8) 19180005 8320 FORMAT(/// ' *** ATTRIBUTE SCALE FACTOR = ', G20.8, 19190005 * ', DERIVED FROM ', A3, ' #', I6, '.') 19200016 8340 FORMAT(/ ' *** ATTRIBUTE HISTOGRAM SEGMENT:'/ 19210020 * ' (THE COMPLETE HISTOGRAM HAD BINS NUMBERED ', 19220020 * I5, ' TO ', I5, '.)'/ 19230020 * ' (DATA VALUES OUTSIDE BIN NUMBERS +/- ', 19240020 * I5, ' WILL BE SCALED TO VALUES > ', F7.1, ')'//) 19250020 8900 FORMAT(4X,A4,I1,' SUCCESSFULLY COMPLETED AT TIME: ',5A4, 19260005 * ', ', I4, ' CDPS PROCESSED') 19270005 C====================================================================== 19280005 C 19290005 C ERROR MESSAGES 19300005 C 19310005 9000 FORMAT('0******************************************************'/ 19320005 * ' *** AVEL SEISPARM ERROR ***'/ 19330005 * ' *** KPNA =',A6,', KPRNO=',I6,', NREC=',I6,' ***'/ 19340005 * ' *** SEISPARM RECORD LENGTH = ',I6,' ***'/ 19350005 * ' ******************************************************') 19360005 C 19370005 9020 FORMAT('0******************************************************'/ 19380005 * ' *** WARNING: VELOCITY PROFILES WERE NOT FOUND ***'/ 19390005 * ' *** FOR',I6,' CDP(S). ***'/ 19400005 * ' ******************************************************') 19410005 C 19420005 9030 FORMAT('0******************************************************'/ 19430005 * ' *** WORK FILE ALLOCATION ERROR: ***'/ 19440005 * ' *** DDNAME = ', A8,' ***'/ 19450005 * ' *** # RECORDS = ', I8,' ***'/ 19460005 * ' *** RECORD LENGTH = ', I8,' ***'/ 19470005 * ' *** UPAWRK ERROR = ', I8,' ***'/ 19480005 * ' *** SVC99 ERROR = ', Z8,' ***'/ 19490005 * ' ******************************************************') 19500005 C 19510005 9045 FORMAT('0******************************************************'/ 19520005 * ' *** OUT OF SPACE ON WORK FILE #',I1,8X,' ***'/ 19530005 * ' *** EXCEEDED CAPACITY OF ', I8,' RECORDS ***') 19540005 C 19550005 9046 FORMAT(' *** CHECK LINE CARD COLS 61-65. ***'/ 19560005 * ' ******************************************************') 19570005 C 19580005 9047 FORMAT(' *** CHECK AVEL CARD 1, COLS 21-25. ***'/ 19590005 * ' ******************************************************') 19600005 C 19610005 9050 FORMAT('0******************************************************'/ 19620005 * ' *** INPUT SEISMIC DATA MISSING ***'/ 19630005 * ' *** KPFCF = ',I6,', KPMITF = ',I6,' ***'/ 19640005 * ' ******************************************************') 19650005 C 19660005 9060 FORMAT('0******************************************************'/ 19670005 * ' *** WORK FILE UNALLOCATION ERROR: ***'/ 19680005 * ' *** DDNAME = ', A8,' ***'/ 19690005 * ' *** UGUWRK ERROR = ', I8,' ***'/ 19700005 * ' *** SVC99 ERROR = ', Z8,' ***'/ 19710005 * ' ******************************************************') 19720005 C 19730005 9070 FORMAT('0******************************************************'/ 19740005 * ' *** ERROR: NO CDPS WITHIN THE PROCESSING RANGE ***'/ 19750005 * ' *** HAD VELOCITY PROFILES. ***'/ 19760005 * ' *** ***'/ 19770005 * ' *** SOLUTION: CHECK CARD 1, COLS 11-20. RUN ***'/ 19780005 * ' *** NMOC, USING EITHER "VFU" OR "VFT". ***'/ 19790005 * ' ******************************************************') 19800005 C 19810005 9080 FORMAT('0******************************************************'/ 19820005 * ' *** BAD VELOCITY ENCOUNTERED: ***'/ 19830005 * ' *** CDP = ', I8,' ***'/ 19840005 * ' *** SAMPLE INDEX = ', I8,' ***'/ 19850005 * ' *** VELOCITY = ', G12.5,' ***'/ 19860005 * ' *** ***'/ 19870005 * ' *** CURE: RERUN NMOC TO REGENERATE COMPLETE ***'/ 19880005 * ' *** VELOCITY PROFILES. ***'/ 19890005 * ' ******************************************************') 19900005 C 19910005 9100 FORMAT('0******************************************************'/ 19920005 * ' *** SEISMIC TRACE SAMPLE INTERVAL (',I6,') ***'/ 19930005 * ' *** DOES NOT MATCH LINE CARD VALUE (',I6,') ***'/ 19940005 * ' ******************************************************') 19950005 C 19960022 9150 FORMAT('0******************************************************'/ 19970022 * ' *** INTEGER OVERFLOW ON HISTOGRAM ANALYSIS ***'/ 19980022 * ' *** NO VALID HISTOGRAM WAS COMPUTED. ***'/ 19990022 * ' ******************************************************') 20000022 C 20010005 9800 FORMAT(' EXIT CODES: KPRTF = ', I5,', KPDRTF = ', I5, 20020005 * ' KPMOTF = ', I5, ', KPLOTF = ', I5, ', KPMITF = ', 20030005 * I5) 20040005 C 20050005 9900 FORMAT('0******************************************************'/ 20060005 * ' *** NUMBER OF RESERVED WORDS REQUESTED BY AVEL:', 20070005 * T50, I10/ 20080005 * ' *** TOTAL NUMBER OF RESERVED WORDS:', T50, I10/ 20090005 * ' *** NUMBER OF UNRESERVED WORDS NEEDED:', T50, I10/ 20100005 * ' *** NUMBER OF UNRESERVED WORDS AVAILABLE:', T50, I10/ 20110005 * ' ******************************************************') 20120005 END 20130005