CTITLE SANSTAK -- COHERENT STACKS
C***********************************************************************
C                 COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991            *
C***********************************************************************
CA
CA    AUTHOR         J.V.S. HARVEY
CA    LANGUAGE       VS FORTRAN (77) FOR VECTORIZATION
CA    SYSTEM         IBM ONLY
CA    REWRITTEN      30 NOV 1988
C     REVISED        02-17-89 JJC FOR SPARC PRODUCTION.
CA
CA
CA    THIS SUBROUTINE UPDATES THE COHERENCY STACKS
CA
CA    ****************************************************************
CA    ***     NOTE:  THIS ROUTINE REPLACES SACNAX (ALL ENTRIES)    ***
CA    ****************************************************************
CA
CA
CA          CALL SANSTAK( REFX,   MDLF,
CA                        NUMVEL, VELMIN, VELINC,
CA                        NUMFRQ, FRQMIN, FRQINC,
CA                        NSPECT, CSPECT, CSTACK )
CA
CA
CA    IN/OUT  ARGUMENT  TYPE  DESCRIPTION
CA
CA    IN      REFX        R4  REFERENCE X VALUE
CA    IN      MDLF        I4  FREQUENCY INCREMENT DOUBLING FACTOR
CA
CA    IN      NUMVEL      I4  NUMBER OF VELOCITY LABELS
CA    IN      VELMIN      R4  MINIMUM VELOCITY LABEL
CA    IN      VELINC      R4  VELOCITY LABEL INCREMENT
CA
CA    IN      NUMFRQ      I4  NUMBER OF DISPLAY FREQUENCY SAMPLES
CA    IN      FRQMIN      R4  MINIMUM FREQUENCY LABEL
CA    IN      FRQINC      R4  FREQ-AXIS LABEL INCREMENT
CA
CA
CA    IN      NSPECT      I4  LENGTH OF INPUT SPECTRA (COMPLEX PAIRS)
CA
CA    IN      CSPECT      R4  INPUT SPECTRA (0 TO NYQUIST)
CA                               1) = REAL PART
CA                               2) = IMAG PART
CA               ( 2-D ARRAY DIMENSIONED:  2 BY NSPECT )
CA
CA
CA    UPDATE  CSTACK      R4  COHERENCY STACKS
CA               ( 3-D ARRAY DIMENSIONED:  NUMFRQ BY NUMVEL BY 2 )
CAEND
C***********************************************************************
C
C     SUBROUTINES CALLED:  (NONE)
C
C***********************************************************************
C
      SUBROUTINE SANSTAK( REFX,   MDLF,
     *                    NUMVEL, VELMIN, VELINC,
     *                    NUMFRQ, FRQMIN, FRQINC,
     *                    NSPECT, CSPECT, CSTACK )
      IMPLICIT INTEGER (A-Z)
C
      REAL         REFX
C
      REAL         VELMIN
      REAL         VELINC
C
      REAL         FRQMIN
      REAL         FRQINC
C
      REAL         CSPECT(2,NSPECT)
C
      REAL         CSTACK(NUMFRQ,NUMVEL,2)
C--------------------------------------------------------------------
C
C                              LOCAL CONSTANT
C
      REAL*8      PI
      PARAMETER  ( PI = 3.14159265 )
C--------------------------------------------------------------------
C
C                        REAL VARIABLES -- LOCAL
C
      REAL    COSPHS
      REAL    SINPHS
      REAL    FREQ
      REAL    PHASE
      REAL    PX
      REAL    RTERM
      REAL    ITERM
      REAL    VEL
C
      REAL    COS
      REAL    SIN
C
C***********************************************************************
C***                                                                ****
C***                PHASE SHIFT AND STACKING OF THE TRACES          ****
C***                                                                ****
C***********************************************************************
C
      JFMIN = 1 + MDLF*FRQMIN/FRQINC
C
      VEL   = VELMIN
      DO 25 IVF = 1, NUMVEL
         PX   = 2.0*PI*( REFX/VEL )
C
         FREQ = FRQMIN
         DO 20 KF = 1, NUMFRQ
            PHASE  = FREQ*PX
C
            COSPHS = COS( PHASE )
            SINPHS = SIN( PHASE )
C
            JF     = JFMIN + ( KF - 1 )*MDLF
C
            IF( JF .LE. NSPECT ) THEN
               RTERM = CSPECT(1,JF)
               ITERM = CSPECT(2,JF)
C
               CSTACK(KF,IVF,1) = CSTACK(KF,IVF,1)
     *                          + ( RTERM*COSPHS - ITERM*SINPHS )
C
               CSTACK(KF,IVF,2) = CSTACK(KF,IVF,2)
     *                          + ( RTERM*SINPHS + ITERM*COSPHS )
               ENDIF
C
            FREQ = FREQ + FRQINC
 20         CONTINUE
C
         VEL = VEL + VELINC
 25      CONTINUE
      RETURN
      END