CTITLESAVSPB -- DOUBLE PRECISION TRANSFER FUNCTION APPL. FOR VSPB 00000010 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR R. D. KNIGHT 00000020 CA DESIGNER R. D. KNIGHT 00000030 CA LANGUAGE FORTRAN H 00000040 CA SYSTEM S/370 00000050 CA WRITTEN DEC 1980 00000055 C REVISED MAY 1987 BY RDK: REVISE WHITE NOISE APPLICATION 00000056 C TO WHITEN AMPLITUDE INSTEAD OF 00000057 C POWER. 00000058 CA 00000060 CA 00000070 CA CALL SAVSPB(A,B,BUF,C,D,DAWRK,EPT,IETM,INH,IRECP,IREFTR,ISTM,IWRT,00000080 CA * KPMITF,KPMOTF,KPPRNT,KPRTF,KPWRKD,LOG,L2,NDX,NLC,NPTS,NROUT,NRT, 00000090 CA * NTOUT,PERCNT,RECMNE,SPT,THL,TRANS1,TRANS2,TRCMNE) 00000100 CA 00000110 CA 00000120 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00000130 CA 00000140 CA SCR A R8 SCRATCH FOR FFT 00000150 CA SCR B R8 SCRATCH FOR FFT 00000160 CA SCR BUF R4 BUFFER FOR INPUT HEADER/TRACE 00000170 CA SCR C R8 SCRATCH FOR FFT 00000180 CA SCR D R8 SCRATCH FOR FFT 00000190 CA IN/OUT DAWRK I4 REC ADDRESS FOR DATA WORK FILE 00000200 CA IN EPT I4 END SHOTPOINT TO PROCESS 00000205 CA IN IETM I4 END BLOCK FOR ANALYSIS WINDOW 00000210 CA IN INH I4 ADDRESS OF INPUT HEADER/TRACE 00000220 CA IN IRECP I4 PREVIOUS RECORD PROCESSED 00000230 CA IN IREFTR I4 CHANNEL # OF THE MONITOR TRACE 00000240 CA IN ISTM I4 START BLOCK OF ANALYSIS WINDOW 00000250 CA IN IWRT I4 FILTER RESPONSE OUTPUT SWITCH 00000260 CA IN KPMITF I4 COMMON P ELEMENT/INPUT SWITCH 00000270 CA IN KPMOTF I4 COMMON P ELEMENT/OUTPUT SWITCH 00000280 CA IN KPPRNT I4 COMMON P ELEMENT/OUTPUT UNIT NO 00000285 CA IN KPRTF I4 COMMON P ELEMENT/ERROR SWITCH 00000290 CA IN KPWRKD I4 COMMON P ELEMENT/WORK FILE DCB 00000300 CA IN LOG I4 BASE 2 LOG OF L2 00000310 CA IN L2 I4 AUGMENTED ANALYSIS GATE LENGTH 00000320 CA IN/OUT NDX I4 MONITOR TRACE DISK ADDR ARRAY 00000330 CA IN/OUT NLC I4 COUNTER FOR INPUT TRACES READ 00000340 CA IN NPTS I4 RECORD LENGTH IN SAMPLES 00000350 CA IN/OUT NROUT I4 COUNTER FOR MONITOR TRACES OUT 00000360 CA IN/OUT NRT I4 COUNTER FOR MONITOR TRACES IN 00000370 CA IN/OUT NTOUT I4 COUNTER FOR TOTAL TRACES OUT 00000380 CA IN PERCNT R4 WHITE NOISE FACTOR 00000390 CA IN RECMNE R8 HEADER MNEMONIC FOR RECORD NO. 00000400 CA IN SPT I4 STARTING SHOTPOINT TO PROCESS 00000405 CA IN THL I4 TRACE HEADER LENGTH 00000410 CA IN/OUT TRANS1 R8 REAL PART OF TRANSFER FUNCTION 00000420 CA IN/OUT TRANS2 R8 IMAG PART OF TRANSFER FUNCTION 00000430 CA IN TRCMNE R8 HEADER MNEMONIC FOR TRACE NO. 00000440 CA 00000450 CA THIS ROUTINE CALCULATES THE SMOOTHING FILTER WHICH IS THE 00000460 CA TRANSFER FUNCTION FROM THE AVERAGE MONITOR TRACE TO EACH 00000470 CA INDIVIDUAL MONITOR, AND APPLIES IT TO EACH VSP TRACE IN THE SHOT. 00000480 C 00000490 SUBROUTINE SAVSPB(A,B,BUF,C,D,DAWRK,EPT,IETM,INH,IRECP,IREFTR, 00000500 * ISTM,IWRT,KPMITF,KPMOTF,KPPRNT,KPRTF,KPWRKD,LOG,L2,NDX,NLC,NPTS, 00000510 * NROUT,NRT,NTOUT,PERCNT,RECMNE,SPT,THL,TRANS1,TRANS2,TRCMNE ) 00000520 C 00000530 C INTEGER CONSTANTS/ARRAYS/VARIABLES--PARM LIST 00000540 C 00000550 INTEGER DAWRK 00000560 INTEGER EPT 00000562 INTEGER NDX ( 1) 00000565 INTEGER SPT 00000570 INTEGER THL 00000575 C 00000580 C REAL CONSTANTS--LOCAL 00000590 C 00000600 REAL*8 CABS 00000610 REAL*8 DENOM 00000620 REAL*8 DUMDP 00000630 REAL*8 RABS 00000640 C 00000650 C REAL ARRAYS--PARAMETER LIST 00000660 C 00000670 REAL*8 A ( 1) 00000680 REAL*8 B ( 1) 00000690 DIMENSION BUF ( 1) 00000700 REAL*8 C ( 1) 00000710 REAL*8 D ( 1) 00000720 REAL INH ( 1) 00000730 REAL*8 TRANS1 ( 1) 00000740 REAL*8 TRANS2 ( 1) 00000750 C 00000760 C REAL CONSTANTS--PARAMETER LIST 00000770 C 00000780 REAL*8 RECMNE 00000790 REAL*8 TRCMNE 00000800 C 00000810 C CHECK FOR NO MORE INPUT 00000820 IF (KPMITF .NE. 0) GO TO 10 00000830 C 00000840 IF (KPMOTF .EQ. 1) GO TO 70 00000850 GO TO 50 00000860 C 00000870 C RETRIEVAL OF INFORMATION FROM THE TRACE HEADER 00000880 C 00000890 10 CALL USRTHV (INH, RECMNE ,IREC) 00000900 CALL USRTHV (INH, TRCMNE ,ITR) 00000910 C 00000920 IF(IREC.GT.EPT .OR. IREC.LT.SPT .OR. ITR.NE.IREFTR) GO TO 30 00000930 C 00000940 NRT=NRT+1 00000950 IF(NRT.EQ.1) CALL ARSET(A,4*L2,0.0) 00000955 NDX(NRT)=DAWRK 00000960 C 00000970 DO 20 J=ISTM,IETM 00000980 K=J-ISTM+1 00000990 20 A(K)=A(K)+DBLE(INH(J+THL)) 00001000 C 00001010 30 CALL FOWDSD (KPWRKD, DAWRK, INH ) 00001020 C 00001030 40 KPRTF = 0 00001040 RETURN 00001050 C 00001055 C ==================================================================00001060 C SAVE INPUT TRACE 00001070 C ==================================================================00001080 C 00001085 50 KPMOTF = 1 00001090 NLC = DAWRK-1 00001100 DAWRK = 1 00001110 C 00001120 WRITE(KPPRNT, 9000 ) NRT,NLC 00001130 C 00001140 DUMDP=1.D00/DFLOAT(NRT) 00001150 C 00001160 DO 60 I=1,NPTS 00001170 60 A(I)=A(I)*DUMDP 00001180 C 00001190 CALL MFORAX(LOG,A,B,-1) 00001200 C 00001210 NTOUT=0 00001220 NROUT=0 00001230 C 00001240 70 NTOUT=NTOUT+1 00001250 NRDX=NTOUT 00001260 IF(NTOUT.GT.NLC) GO TO 210 00001270 C 00001272 KPRTF=1 00001274 C 00001276 CALL FORDSD(KPWRKD,NRDX,BUF) 00001280 CALL USRTHV(BUF,RECMNE,IREC) 00001290 CALL USRTHV(BUF,TRCMNE,ITRC) 00001300 C 00001303 IF(IREC.LT.SPT .OR. IREC.GT.EPT) GO TO 220 00001306 C 00001310 C IF A REF TRACE, MAY HAVE BEEN PROCESSED ALREADY 00001320 C ELSE TEST FOR STILL IN SAME SHOTPOINT AS PREVIOUS TRACE 00001330 C 00001340 IF(IREC.EQ.IRECP) GO TO 140 00001350 C 00001360 C ============================================================ 00001370 C NEW SHOTPOINT, BUMP UP OUTPUT RECORD COUNTER AND RESET IRECP 00001380 C ============================================================ 00001390 C 00001400 NROUT=NROUT+1 00001410 IRECP=IREC 00001420 C 00001430 C GET THE DISK ADDRESS FOR NEW SHOTPOINT REF TRACE 00001440 C 00001450 NRDX=NDX(NROUT) 00001460 C READ REFERENCE TRACE FROM DISK UNLESS ALREADY IN BUF FROM ABOVE 00001470 C (E.G. REF TRACE IS FIRST TRACE OF SHOTPOINT) 00001480 IF(ITRC.NE.IREFTR) CALL FORDSD(KPWRKD,NRDX,BUF) 00001490 C 00001500 C CLEAR ARRAYS, PREPARE TO COMPUTE TRANSFER FUNCTION TO AVERAGE REF 00001510 C 00001520 CALL ARSET(C,2*L2,0.0) 00001530 CALL ARSET(D,2*L2,0.0) 00001540 C 00001550 C PLACE THE PORTION OF REF TRACE TO BE ANALYZED IN C FOR FFT 00001560 C 00001570 DO 80 I=ISTM,IETM 00001580 J=I-ISTM+1 00001590 80 C(J)=DBLE(BUF(I+THL)) 00001600 C 00001610 C FFT THE WINDOWED REF TRACE FOR THIS SHOTPOINT, RESULTS IN C,D 00001620 C 00001630 CALL MFORAX(LOG,C,D,-1) 00001640 C 00001650 C COMPUTE THE RESPONSE FUNCTION FROM AVERAGE REF TRACE TO REF TRACE 00001660 C IN ORDER TO ENABLE ADDITION OF WHITE NOISE TO TRANSFER FUNCTION 00001670 C THE RESPONSE FUNCTION IS THE INVERSE OF THE TRANSFER FUNCTION 00001680 C 00001690 CABS=0.D00 00001700 IF(PERCNT.LE.0.) GO TO 100 00001710 C 00001720 DO 90 I=1,L2 00001730 C 00001740 C DO COMPLEX DIVIDE C+DI/A+BI 00001750 C 00001760 C DENOM = A(I)*A(I)+B(I)*B(I) 00001770 C IF(DENOM.EQ.0.D00) DENOM=1.D00 00001780 C RABS = DSQRT((C(I)*C(I)+D(I)*D(I))/DENOM) 00001790 RABS = DSQRT (C(I)*C(I)+D(I)*D(I)) 00001791 CABS = DMAX1(RABS,CABS) 00001800 90 CONTINUE 00001810 C 00001820 100 WNOIS=PERCNT/100.*CABS 00001830 C 00001840 C COMPUTE THE TRANSFER FUNCTION FROM REF TRACE TO AVERAGE REF TRACE-00001850 C I.E., DO COMPLEX DIVIDE A+BI/C+DI 00001851 C RESULTS IN TRANS1, TRANS2 00001860 C 00001870 DO 110 I=1,L2 00001880 DENOM=C(I)*C(I)+D(I)*D(I) 00001890 IF(WNOIS.NE.0.0 ) DENOM=DENOM+WNOIS*DSQRT(C(I)*C(I)+D(I)*D(I)) 00001900 IF(DENOM.EQ.0.D00) DENOM=1.D00 00001901 TRANS1(I)=(C(I)*A(I)+D(I)*B(I))/DENOM 00001910 110 TRANS2(I)=(C(I)*B(I)-A(I)*D(I))/DENOM 00001920 C 00001930 C ==================================================================00001940 C IF TRANSFER FUNCTION OUTPUT SELECTED, MOVE TRANSFER FUNCTION 00001950 C TO SIMULATE DATA TRACE AND GO ALLOW NORMAL OUTPUT 00001960 C ==================================================================00001970 C 00001980 IF(IWRT.EQ.0) GO TO 130 00001990 120 CALL ARMVE(TRANS1,C,2*L2) 00002000 CALL ARMVE(TRANS2,D,2*L2) 00002010 GO TO 190 00002020 C 00002030 C ==================================================================00002040 C ELSE APPLY TRANSFER FUNCTION TO DATA TRACE. IF CURRENT TRACE IS 00002050 C A REFERENCE TRACE, THE FFT IS STILL IN C AND D SO SKIP FFT 00002060 C ==================================================================00002070 C 00002080 130 IF(ITRC.EQ.IREFTR) GO TO 170 00002090 C 00002100 C GET NEXT DATA TRACE FROM THE DISK 00002110 C 00002120 NRDX=NTOUT 00002130 CALL FORDSD(KPWRKD,NRDX,BUF) 00002140 GO TO 150 00002150 C 00002160 C IF TRANSFER FUNCTION OUTPUT SELECTED, GO DO IT INSTEAD OF DATA 00002170 C 00002180 140 IF(IWRT.NE.0) GO TO 120 00002190 C 00002200 C PREPARE FOR FFT AND APPLY ANALYSIS WINDOW 00002210 C 00002220 150 CALL ARSET(C,2*L2,0.0) 00002230 CALL ARSET(D,2*L2,0.0) 00002240 C 00002250 DO 160 I=1,NPTS 00002260 160 C(I)=DBLE(BUF(I+THL)) 00002270 C 00002280 C FFT DATA TRACE, RESULTS IN C,D 00002290 C 00002300 CALL MFORAX(LOG,C,D,-1) 00002310 C 00002320 C APPLY THE TRANSFER FUNCTION TO THE CURRENT TRACE 00002330 C 00002340 170 DO 180 I=1,L2 00002350 RABS=C(I) 00002360 CABS=D(I) 00002370 C(I)=RABS*TRANS1(I)-CABS*TRANS2(I) 00002380 180 D(I)=RABS*TRANS2(I)+CABS*TRANS1(I) 00002390 C 00002400 C INVERSE TRANSFORM BACK TO TIME, RESULTS IN C 00002410 C 00002420 190 CALL MFORAX(LOG,C,D,1) 00002430 C 00002440 C REPLACE IN TRACE BUFFER 00002450 C 00002460 DO 200 I=1,NPTS 00002470 200 BUF(I+THL)=SNGL(C(I)) 00002480 C 00002490 RETURN 00002500 C 00002510 210 KPMOTF=0 00002520 KPRTF =0 00002530 C 00002535 220 RETURN 00002540 C 00002550 9000 FORMAT(//,1H ,' TOTAL REFERENCE TRACES =',I5,/, 00002560 * 1H ,' TRACES IN DATA SET =',I5) 00002570 C 00002575 END 00002580