C
C***********************************************************************
C                 COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991            *
C***********************************************************************
CTITLESADM3DA -- CALCULATE ARRAY FOR DEPTH-VARIABLE-VELOCITY DMO
CA
CA   DESIGNER     JAMES SUN
CA   AUTHOR       JAMES SUN
CA   LANGUAGE     FORTRAN 77
CA   SYSTEM       CRAY/IBM
CA   WRITTEN      04/19/90
C    REVISED      12/17/91  JJC - MODIFIED TO MEET SPARC STANDARDS.
CA
CA
CA CALLING PROCEDURE:
CA     SUBROUTINE SADM3DA(GAMMA,V2,T,V,KPNA,KPRNO,DT,IPR,NT,IVFLAG)
CA
C   CALLING ARGUMENTS
CA
CA     OUTPUT     GAMMA     CALCULATED TIME VARYING SCALING 1-D ARRAY
CA     IN         V2        1-D WORK ARRAY FOR VRMS AT EVERY SAMPLE
CA     IN         T         1-D WORK ARRAY FOR INPUT TIME
CA     IN         V         1-D WORK ARRAY FOR INPUT VRMS
CA     IN         KPNA      PROCESS NAME
CA     IN         KPRNO     PROCESS NUMBER
CA     IN         DT        TIME SAMPLING RATE (SEC)
CA     IN         IPR       PRINT UNIT
CA     IN         NT        NUMBER OF TIME SAMPLES
C
C
C
      SUBROUTINE SADM3DA(GAMMA,V2,T,V,KPNA,KPRNO,DT,IPR,NT,IVFLAG)      09380003
C                                                                       01260000
C
      IMPLICIT   INTEGER(A-Z)
C                                                                       01260000
C
      CHARACTER*80  CARD                                                01750000
      CHARACTER*4   KPNA                                                01760000
C                                                                       01760000
C
      REAL     GAMMA
      REAL     V2
      REAL     T
      REAL     V
      REAL     DT
      REAL     WORK
      REAL     TMP1
      REAL     DELT
      REAL     TMP2
      REAL     TL
      REAL     V2TMP1
      REAL     V4TMP1
      REAL     VSQ
      REAL     V2TMP2
      REAL     V4TMP2
      REAL     DV2DT
C                                                                       01760000
C
      DIMENSION GAMMA(1)                                                01760000
      DIMENSION V2(1)                                                   01760000
      DIMENSION T(1)                                                    01760000
      DIMENSION V(1)                                                    01760000
C                                                                       01760000
C
      IDT=NINT(DT*1000.)                                                01760000
      CALL ARSET(GAMMA,NT,1.0)
C                                                                       01760000
C     READ IN (T,VRMS) PAIRS                                            01760000
C                                                                       01760000
      J = 0
      DAC = 1                                                           02060000
  100 CALL FORC (KPNA, KPRNO, DAC, CARD, * 140)                         02070000
      IF(CARD(8:10) .NE. 'TVR') GO TO 100
C                                                                       02090000
C
      ICOL=11
  120 ICOL=ICOL+5
      IF(ICOL.GE.76) GO TO 100
      IF(CARD(ICOL:ICOL+4) .NE. '     ') THEN
        J=J+1
        CALL USCHFT(CARD,ICOL,5,T(J))
        ICOL=ICOL+5
        CALL USCHFT(CARD,ICOL,5,V(J))
      ENDIF
      GO TO 120
C
C     NO RMS-V TREND INPUT
C
  140 CONTINUE
      IF(J.EQ.0) THEN
        IVFLAG=1
        WRITE(IPR,8020)
        GO TO 240
      ENDIF
C
C     EXTRAPOLATE TO T=0
C
      IF(T(1).GT.0) THEN
        DO 160 I=J,1
          T(I+1)=T(I)
  160   V(I+1)=V(I)
        T(1)=0.
        J=J+1
      ENDIF
C
C
      IVFLAG=0
      WRITE(IPR,8040)
C
C     CALCULATE INTERVAL VELOCITY
C
      TMP1=0
      DO 180 I=2,J
        DELT=T(I)-T(I-1)
        TMP2=T(I)*V(I)**2
        V(I-1)=(TMP2-TMP1)/DELT
        TMP1=TMP2
  180 CONTINUE
      V(J)=V(J-1)
C
C     CALCULATE RMS VELOCITY AT ALL SAMPLES
C
      V2(1)=SQRT(V(1))
      TMP1=0.
      TL=0.
      IJ=2
      DO 200 I=2,NT
        TL=TL+IDT
        IF(TL.GE.T(IJ)) THEN
          IJ=MIN0(IJ+1,J)
        ENDIF
        TMP2=TMP1+V(IJ-1)*FLOAT(IDT)
        V2(I)=SQRT(TMP2/TL)
  200 TMP1=TMP2
C
C     CALCULATE GAMMA FUNCTION
C                        GAMMA = 1.5*V4**4/V2**4 - T/V2*(DV2/DT) - 0.5
C
      TL=0.
      V2TMP1=0.
      V4TMP1=0.
      VSQ=V2(1)**2
      DO 220 IT=2,NT-1
        TL=TL+IDT
        V2TMP2=TL*V2(IT)**2
        V4TMP2=VSQ*VSQ*IDT+V4TMP1
        VSQ=(V2TMP2-V2TMP1)/IDT
        DV2DT=(V2(IT+1)-V2(IT-1))/FLOAT(2*IDT)
        GAMMA(IT)=      1.5*V4TMP2*TL/V2TMP2**2-TL/V2(IT)*DV2DT-0.5
        V2TMP1=V2TMP2
        V4TMP1=V4TMP2
  220 CONTINUE
      GAMMA(1)=1.
      GAMMA(NT)=GAMMA(NT-1)
C
C
 8000 FORMAT(A80)
 8020 FORMAT('  NO TVR CARD FOUND => VELOCITY INDEPENDENT DMO')
 8040 FORMAT('  TVR CARD FOUND => VERTICAL VELOCITY DEPENDENT DMO')
C
C
  240 CONTINUE
C
C
      RETURN
      END