CTITLESAVEL -- VELOCITY INTERPOLATION ROUTINE C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA CA AUTHOR R. C. DECKER CA DESIGNER R. C. DECKER CA LANGUAGE S/370 FORTRAN H CA SYSTEM IBM / CRAY CA DATE 07-13-77 C REVISED 10-17-84 COADY MODIFIED FOR VS FORTRAN C REVISED 01-21-85 J.SUN MODIFIED FOR CRAY FORTRAN C REVISED 03-19-87 COADY MODIFIED RETURN FLAGS FOR C 1) NO VELF RECORDS FOUND C 2) VELF ID NOT FOUND C 3) CDP OUT OF RANGE C REVISED 12-09-87 VERWEST INCREASED TABLE TO HOLD C UP TO 600 VELF IDS. C LIMIT SET BY MAXVEL CA CA CALL SAVEL(VEL,IVEL,SHOT,NOSAMP,KPNA,KPRNO,IPR,A1,A2, CA * LOW,HIGH,IRNG,IDENT,JJ,IFLG,INTRPF) CA CA VEL - OUTPUT ARRAY OF INTERPOLATED VELOCITIES R4 CA IVEL - FLAG INDICATING WHETHER VELOCITIES FOUND I4 CA -1 - NO VELF SEISPARM RECORDS FOUND OR CA VELF ID NOT FOUND (RUN ABANDON) CA 0 - FOUND CA 1 - NOT FOUND FOR THIS SHOT/CDP CA SHOT - SHOTPOINT OR CDP NUMBER I4 CA NOSAMP - NUMBER OF SAMPLES IN THE DATA I4 CA KPNA - PROCESS NAME (FOR READING CARDS) A4 CA KPRNO - PROCESS NUMBER (FOR READING CARDS) A4 CA IPR - PRINT UNIT NUMBER I4 CA A1 - VELOCITY INPUT ARRAY (FOR INTERPOLATION) R4 CA A2 - VELOCITY INPUT ARRAY (FOR INTERPOLATION) R4 CA LOW - VELOCITY ID FROM 'VELF' ON LEFT OF 'SHOT' I4 CA HIGH - VELOCITY ID FROM 'VELF' ON RIGHT OF 'SHOT' I4 CA IRNG - ARRAY CONTAINING RANGES FOR A PROCESS I4 CA IDENT - ARRAY OF 'VELF' ID'S FOR A PROCESS I4 CA JJ - NUMBER OF ENTRIES IN RANGE ARRAY I4 CA IFLG - INITIAL PROCESS ENTRY FLAG I4 CA 1 - INITIAL ENTRY CA 0 - ANY OTHER ENTRY CA INTRPF - INTERPOLATION FLAG CA 1 - INTERPOLATE SPATIALLY CA 0 - NO SPATIAL INTERPOLATION CA CA CA THIS ROUTINE READS THE RMS-TIME INTERPOLATED VELOCITY CA FUNCTIONS WRITTEN BY THE 'VELF' PROCESSOR AND CALCULATES CA A SPATIALLY INTERPOLATED VELOCITY FUNCTION FOR LOCATION CA 'SHOT'. THIS ROUTINE WILL WORK ON 'SHOT', 'CDP' OR 'FILE' CA DATA USING STANDARD SPARC 'VELF' CODING. THIS ROUTINE CAN BE CA CALLED FROM MANY DIFFERENT PROCESSES USING DIFFERENT VELOCITY CA INFORMATION. CA CA CA SUBROUTINES CALLED: FORP CA ARMVE CA ARSET CA FIXFL CA CAEND C ===================================================================== C FORMAT OF VELF 'RVEL' PARAMETER RECORDS C C WORD 1 WORD 2 WORD 3 WORD 4 WORD 5 WORD 6 WORD 7 WORD 8 C |______|________|______|________|_______|_______|_______|_______| C | VELF | PROCESS| RVEL | ID | NOT | # OF | DATUM | NOT | C |______|_NUMBER_|______|_NUMBER_|_USED__|_PARMS_|_ELEV._|_USED__| C C WORD 9 WORD 10 ..... WORD 104 C |______|_______| ..... |________| A VELOCITY FOR EACH SAMPLE C | VEL. | VEL. | ..... | VEL. | IS OUTPUT IN THESE RECORDS C |______|_______| ..... |________| AS AN INTEGER. C -------- C ===================================================================== C C C SUBROUTINE SAVEL(VEL,IVEL,SHOT,NOSAMP,KPNA,KPRNO,IPR,A1,A2, + LOW,HIGH,IRNG,IDENT,JJ,IFLG,INTRPF) C PARAMETER (MAXVEL = 600) C C INTEGER VARIABLES AND CONSTANTS C INTEGER S1CPCH INTEGER S1CVBN INTEGER DA1 INTEGER DA2 INTEGER DAP INTEGER DAC INTEGER IVEL INTEGER SHOT INTEGER NOSAMP INTEGER IPR INTEGER RVEL INTEGER LOW INTEGER HIGH INTEGER JJ INTEGER IFLG C INTEGER IRNG (1) INTEGER IDENT (1) C INTEGER TABLE (400) INTEGER TABLE (2*MAXVEL) INTEGER DENTRY(104) INTEGER DATTR (96) C CRAY CHARACTER*80 CARD INTEGER CARD(20) C C REAL VARIABLES AND CONSTANTS C REAL VEL (1) REAL A1 (1) REAL A2 (1) C EQUIVALENCE (DENTRY(9),DATTR(1)) C C CHARACTER VARIABLES AND CONSTANTS C CRAY CHARACTER*4 RVELCH INTEGER RVELCH C DATA RVELCH /'RVEL'/ C C INITIALIZE PARAMETERS AND BUILD C THE SHOTPOINT OR CDP TABLE C CALL S1MVCH(RVELCH,1, RVEL,1, 4) CDEBUG C WRITE(IPR,9900) IVEL,SHOT,NOSAMP,KPNA,LOW,HIGH,JJ,IFLG C9900 FORMAT(5X,'SAVEL:IVEL/SHOT/NOSAMP/KPNA/LOW/HIGH/ JJ/IFLG/'/ C + 11X, I4, I5, I7, A5, I4, I5, I4, I5) C IF(IVEL.EQ.1) GO TO 190 C C FOR ENTRIES OTHER THAN FIRST BRACH TO 45 C IF (IFLG .EQ. 0) GO TO 45 DAP = 1 II = -1 C 10 CALL FORP('VELF',0,DAP,104,DENTRY, *25) C CRAY IF( DENTRY(3) .NE. RVEL) GO TO 10 IF( S1CPCH(DENTRY(3),1, RVEL,1, 4) .NE. 0) GO TO 10 IF( II .EQ. -1) GO TO 20 IF( DENTRY(4) .EQ. TABLE(II) ) GO TO 10 C 20 II = II + 2 TABLE(II) = DENTRY(4) TABLE(II+1) = DAP - 1 GO TO 10 C C CHECK FOR VELF SEISPARM RECORDS FOUND -- IF NOT THEN ABANDON C 25 IF (II .EQ. -1) THEN WRITE(IPR,8000) 8000 FORMAT(// 5X,'*** ERROR *** VELF RECORDS NOT FOUND'/ + 5X,'RUN ABANDON') IVEL = -1 RETURN END IF C JR = II + 1 C C WRITE(IPR,8001) II,JR C8001 FORMAT(5X,'FROM SAVEL VELF SEISPARM SEARCH II=',I8,' JR=',I8) C C WRITE(IPR,9901) (TABLE(I),I=1,JR) C9901 FORMAT(5X,'FROM SAVEL TABLE ARRAY : '/, 100(5X,2I10/) ) C C BUILD THE RANGE AND VELOCITY ID TABLES FROM PROCESS 'VEL' C CARDS ON THE FIRST CALL FROM EACH PROCESS. C JJ = 1 DAC = 1 C C BUILD RANGE AND IDENTITY ARRAYS FROM PROCESS 'VEL' CARDS IF ANY C 35 CALL FORC(KPNA,KPRNO,DAC,CARD, *40) C C WRITE(IPR,9902) KPNA,KPRNO,DAC,CARD C9902 FORMAT(5X,A4,I1,I10,20A4) C IF( S1CPCH(CARD,8, 'VEL',1,3) .NE. 0) GO TO 35 IRNG(JJ) = S1CVBN(CARD,11,5) IRNG(JJ+1) = S1CVBN(CARD,16,5) IDENT(JJ/2+1) = S1CVBN(CARD,21,5) IF(IRNG(JJ+1).EQ.0) IRNG(JJ+1) = IRNG(JJ) JJ = JJ + 2 GO TO 35 C C CHECK FOR NO 'VEL' CARDS FOR THIS PROCESS C 40 IF (JJ .EQ. 1) THEN IVEL = 1 RETURN END IF C IRNG(JJ) = IRNG(JJ-1) JJ = JJ - 1 JR = JJ/2 C IFLG = 0 CDEBUG C WRITE(IPR,9905) JJ, (IRNG(I), I=1,JJ) C9905 FORMAT(5X,'# ENTRIES IN IRNG = ',I4,' IRNG : '/ 50(5X,2I5/) ) C WRITE(IPR,9906) JR, (IDENT(I),I=1,JR) C9906 FORMAT(5X,'# ENTRIES IN IDENT = ',I4,' IDENT : '/ 50(5X,12I5/) ) C C C FIND A VELOCITY FOR 'SHOT' C 45 IF(SHOT.LE.HIGH .AND. SHOT.GE.LOW) GO TO 90 C C INDX = 1 IF(INTRPF.EQ.0) INDX = 2 C CDEBUG C WRITE(IPR,9907) SHOT, INDX C9907 FORMAT(5X,'AT 50 LOOKING FOR SHOT/CDP ',I4,' INDX = ',I4) C DO 50 I = 1,JJ, INDX IF((SHOT.LE.IRNG(I+1) .AND. SHOT.GE.IRNG(I)) .OR. + (SHOT.LE.IRNG(I) .AND. SHOT.GE.IRNG(I+1))) GO TO 55 50 CONTINUE C C IF WE HAVE FALLEN THRU TO HERE THEN THIS SHOT/CDP IS NOT C WITHIN ANY RANGE CODED ON VEL CARDS FOR THIS PROCESS AND C INTERPOLATION IS TURNED OFF (ON LINE CARD OR 1ST PROCESS C CARD). C WRITE(IPR,8010) SHOT, KPNA,KPRNO 8010 FORMAT(3X,'*** WARNING CDP/SHOT #',I4,' NOT WITHIN RANGES CODED', + ' FOR ',A4,I1,' (INTERPOLATION TURNED OFF)'/ + 3X,' VELOCITY FUNCTION SET TO ZERO.') CALL ARSET(VEL, NOSAMP, 0.0) RETURN C C 55 LOW = IRNG(I) HIGH = IRNG(I+1) IF (LOW .GT. HIGH) THEN JL = LOW LOW = HIGH HIGH = JL END IF CDEBUG C WRITE(IPR,9908) I, LOW, HIGH C9908 FORMAT(5X,'AFTER 55 I/LOW/HIGH/ ',3I4) C C IF (MOD(I,2) .EQ. 0) THEN ID1 = IDENT(I/2) ID2 = IDENT(I/2+1) ELSE ID1 = IDENT(I/2+1) ID2 = ID1 END IF C DA1 = 0 DA2 = 0 C C WRITE(IPR,9909) II C9909 FORMAT(5X,'AT LOOP 58 VALUE OF II IS',I6) C DO 58 J = 1,II, 2 IF (ID1 .EQ. TABLE(J)) DA1 = TABLE(J+1) IF (ID2 .EQ. TABLE(J)) DA2 = TABLE(J+1) C 58 CONTINUE C IF (DA1 .EQ.0 .OR. DA2 .EQ. 0) THEN IF (INTRPF .EQ. 1) WRITE(IPR,8020) ID1,ID2 8020 FORMAT(//5X,'*** ERROR VEL ID ',I4,' OR ',I4,' NOT FOUND') IF (INTRPF .EQ. 0) WRITE(IPR,8025) ID1 8025 FORMAT(//5X,'*** ERROR VEL ID ',I4,' NOT FOUND') IVEL = -1 RETURN END IF C JL = 1 60 CALL FORP ('VELF',0, DA1,104, DENTRY, * 70) CALL FIXFL (DATTR(1), A1(JL), DENTRY(6)) JL = JL + 96 IF (JL .GT. NOSAMP) GO TO 70 GO TO 60 C C PICK UP THE VELOCITY FUNCTION C FOR HIGH C 70 IF (ID1 .EQ. ID2) THEN CALL ARMVE (A1, VEL, NOSAMP) CALL ARMVE (A1, A2, NOSAMP) GO TO 200 END IF C JH = 1 80 CALL FORP ('VELF',0, DA2,104, DENTRY, *90) CALL FIXFL( DATTR(1), A2(JH), DENTRY(6)) JH = JH + 96 IF(JH .GT. NOSAMP) GO TO 90 GO TO 80 C C C VELOCITY ARRAYS ARE IN A1 AND A2. C SET UP FOR INTERPOLATION AND DO IT. C 90 DIFF = HIGH - LOW FRACT = (SHOT - LOW)/DIFF C DO 100 I=1,NOSAMP VEL(I) = A1(I) + FRACT * (A2(I)-A1(I)) 100 CONTINUE C C 200 IFLG = 0 RETURN C C NO VELOCITY FUNCTION FOUND. SET C IVEL CODE TO 1 AND RETURN. C 190 IVEL = 1 IFLG = 0 RETURN C END