SUBROUTINE AMPL (AMPX,AMPY,AMPZ,UU)
C
C     ROUTINE FOR COMPUTING COMPLEX VECTORIAL RAY AMPLITUDES
C
C     OUTPUT PARAMETERS
C     AMPX(2),AMPY(2),AMPZ(2) - X,Y AND Z COMPONENTS OF COMPLEX
C     VECTORIAL RAY AMPLITUDES IN THE MODEL COORDINATES. FOR P WAVE
C     IN ANY MEDIUM AND FOR S WAVES IN AN ANISOTROPIC MEDIUM, I=1.
C     FOR S WAVE GENERATED IN AN ISOTROPIC MEDIUM, I=1,2. I=1 AND 2
C     CORRESPOND TO S WAVES SPECIFIED AT THE SOURCE BY VECTORS E1 
C     E2. VECTORS E1 AND E2 TOGETHER WITH UNIT VECTOR TANGENT TO
C     THE RAY FORM A BASIS OF RAY CENTRED COORDINATE SYSTEM.
C     UU - PRODUCT OF RATIOS OF DENSITIES AND COSINES OF INCIDENCE 
C     AND OF REFLECTION/TRANSMISSION AT POINTS WHERE THE RAY CROSSES 
c     INTERFACES.
C
C     CALLED FROM: RECEIV
C     ROUTINES CALLED: POLAR,TRANSL,COEF
C
      DIMENSION Y(18),UN(3),POLD(3),PNEW(3)
      COMPLEX  AMPX(2),AMPY(2),AMPZ(2),CR(3),UC(3),STU(6)
      COMMON /AUXI/  IANI(20),INTR,INT1,IOUT,KRE,IREFR,LAY,NDER,IPRINT,
     1 MPRINT,NTR,ISQRT,NAUX,ISOUR,MAUX,MREG,MDIM,IPOL,MSCON,LOU,
     2 IAMP,MTRNS,ICOEF,IAD,IRHO,ISHEAR,IAC,IRT,mori
      INTEGER CODE
      COMMON /COD/  CODE(50,2),KREF,KC,ITYPE
      COMMON /DENS/ RHO(20)
      COMPLEX PS
      COMMON /RAY/   AY(28,400),DS(20,20),KINT(20),HHH(3,3),tmax,
     1               PS(3,7,20),IS(8,20),DINC,DTOLD,N,IREF,IND,IND1
      COMMON /RAY2/  DRY(3,400)
      COMMON/SOUR/ROS,VPS,VSS
C
      KSS=1
      ISHEAR=0
      ITYPE=CODE(1,2)
      IF(IANI(ISOUR).EQ.0.AND.ITYPE.NE.3)then
        ISHEAR=1
        itype=1
      end if
      ITP=ITYPE
      do 1 i=1,2
      AMPX(i)=CMPLX(0.,0.)
      AMPY(i)=CMPLX(0.,0.)
      AMPZ(i)=CMPLX(0.,0.)
    1 continue
C
 3000 NN=N
      IDD=0
      N2=0
      N1=1
      IRE=IREF
      AL=1.
      AV=1.
C
C  SPECIFICATION OF DISPLACEMENT VECTOR AT SOURCE
C  IN RAY CENTERED COORDINATES
C
      DO 5 I=1,3
      CR(I)=(0.,0.)
    5 CONTINUE
      CR(ITP)=(1.,0.)
      IREF1=IREF-1
      IF(IREF1.EQ.0) GOTO 100
C
C  LOOP OVER INTERFACES
C
      DO 10 I=1,IREF1
      IREF=I
      IF(KC.NE.0) ITYPE=CODE(IREF,2)
      N=KINT(IREF)
      IF(N.EQ.0) THEN
        IDD=1
        GO TO 10
      ELSE
        N1=N2+1
        N2=N
        IF(IDD.NE.0) N2=-N2
        IDD=0
C
C  COMPUTATION OF POLARIZATION VECTORS
C  CONSIDERED POLARIZATION VECTOR(S) ARE STORED IN CORRESPONDING
C  COLUMNS OF THE MATRIX HHH. OTHER COLUMNS ARE ZERO.
C
        CALL POLAR(N1,N2,NN,IREF)
      END IF
      DO 20 K=1,6
      Y(K)=AY(K+1,N)
  20  CONTINUE
      IF(IAMP.GT.0)WRITE(LOU,'(a,2i5,6f10.5)')' AMPL:I,N,Y',I,N,
     1(Y(L),L=1,6)
      DO 30 K=1,3
      POLD(K)=Y(K+3)
      PS(K,7,IREF)=Y(K+3)
  30  CONTINUE
      DO 40 K=1,3
      UN(K)=DS(K,IREF)
  40  CONTINUE
      LAY=IS(1,IREF)
      ITRANS=IS(2,IREF)
      ITR1=ITRANS
      IF(UN(3).GT.0.0) GOTO 50
C
C  RAY STRIKING THE INTERFACE FROM ABOVE
C
      IF(ITRANS.EQ.0) THEN
        LAY=LAY+1
        ITRANS=1
        GOTO 70
      END IF
      IF(ITRANS.GT.0) THEN
        LAY=LAY-1
        ITRANS=0
        GOTO 70
      END IF
C
C  RAY STRIKING THE INTERFACE FROM BELOW
C
  50  IF(ITRANS.EQ.0) THEN
        LAY=LAY-1
        ITRANS=1
        GOTO 70
      END IF
      IF(ITRANS.GT.0) THEN
        LAY=LAY+1
        ITRANS=0
        GOTO 70
      END IF
C
C  SLOWNESS VECTORS ON THE SIDE OF THE INTERFACE WHERE GENERATED
C  WAVE PROPAGATES WERE DETERMINED DURING THE CALL OF TRANSL IN THE
C  ROUTINE OUT. HERE REMAINING SLOWNESS VECTORS ON THE OTHER SIDE 
C  OF THE INTERFACE ARE DETERMINED
C
C  REDEFINITION OF IREF FOR CALL OF ROUTINE TRANSL
C
  70  IF(LAY.EQ.0) THEN
        DO 71 K=4,6
        DO 71 L=1,3
        PS(L,K,IREF)=CMPLX(0.,0.)
  71    CONTINUE
        GO TO 75
      END IF
      IREF=IREF+1
      CALL TRANSL(Y,POLD,PNEW,UN,ITRANS,0)
      IREF=IREF-1
  75  IF(IAMP.ne.0)then
        WRITE(LOU,'(a)')' REFLECTED/TRANSMITTED SLOWNESS VECTORS'
        WRITE(LOU,'(6f12.6)')((PS(L,K,IREF),L=1,3),k=1,6)
      end if
      AL1=DS(12,IREF)/DS(9,IREF)
      AV1=(DS(11,IREF)*ds(10,iref))/(DS(8,IREF)*ds(7,iref))
      AV=AV*AV1
      AL=AL*AL1
      IF(IAMP.GT.0) THEN
        WRITE(LOU,'(A)') ' COSI,COSG,ROI,ROG,VPI,VPG,AL1,AV1,AL,AV'
        WRITE(LOU,'(6F10.5)') DS(9,IREF),DS(12,IREF),DS(8,IREF),
     1  DS(11,IREF),ds(7,iref),ds(10,iref),AL1,AV1,AL,AV
        WRITE(LOU,'(A,/,6F12.5,/,3(3F12.5/))') ' CR,HHH',
     2  CR,((HHH(J,K),J=1,3),K=1,3)
      END IF
C
C  COMPUTATION OF AMPLITUDE COEFFICIENTS OF REFLECTED/TRANSMITTED WAVES
C
C
C  COMPUTATION OF CARTESIAN COMPONENTS OF INCIDENT DISPLACEMENT VECTOR
C
      DO 87 K=1,3
      STU(K)=CMPLX(0.,0.)
      DO 87 J=1,3
      STU(K)=HHH(J,K)*CR(J)+STU(K)
  87  CONTINUE
      IF(IAMP.GT.0)WRITE(LOU,'(A,6F10.5)') ' STU',(STU(K),K=1,3)
      IF(KC.NE.0)ITYPE=CODE(IREF+1,2)
      CALL COEF(STU,CR,ITR1)
      BCR=SQRT(REAL(CR(1)*CONJG(CR(1))+CR(2)*CONJG(CR(2))
     1             +CR(3)*CONJG(CR(3))))
      IF(BCR.LT.1.E-10) THEN
        DO 88 K=1,3
        UC(K)=(0.,0.)
  88    CONTINUE
        GOTO 130
      END IF
  10  CONTINUE
C
C  END OF LOOP OVER INTERFACES
C
C  TERMINATION POINT
C
  100 N1=N2+1
      N2=NN
      IF(KC.NE.0)ITYPE=CODE(IRE,2)
      CALL POLAR(N1,N2,NN,IRE)
C
C COMPUTATION OF CARTESIAN COMPONENTS OF INCIDENT DISPLACEMENT VECTOR
C
      DO 107 K=1,3
      STU(K)=CMPLX(0.,0.)
      DO 107 J=1,3
      STU(K)=HHH(J,K)*CR(J)+STU(K)
 107  CONTINUE
      IF(IAMP.GT.0)WRITE(LOU,'(A,6F10.5)') ' STU',(STU(K),K=1,3)
      DO 105 K=1,6
      Y(K)=AY(K+1,Nn)
      IF(K.LE.3)GO TO 105
      PS(K-3,7,IRE)=Y(K)
  105 CONTINUE
      IF(MREG.NE.0) THEN
        UC(1)=STU(1)
        UC(2)=STU(2)
        UC(3)=STU(3)
        GOTO 110
      END IF
      IF(IAMP.GT.0)then
        WRITE(LOU,'(a)')
     1  ' REFLECTED SLOWNESS VECTORS AT TERMINATION POINT'
        WRITE(LOU,'(6f12.6)')((PS(L,K,IRE),L=1,3),K=1,3)
      end if
C
C COMPUTATION OF CONVERSION COEFFICIENTS     
      KTR=999
      CALL COEF(STU,UC,KTR)
  110 VpEND=1./SQRT(Y(4)*Y(4)+Y(5)*Y(5)+Y(6)*Y(6))
      do 120 k=1,3
      y(k)=ay(k+4,1)
  120 continue    
      Vp0=1./SQRT(Y(1)*Y(1)+Y(2)*Y(2)+Y(3)*Y(3))
      RHO0=0.2*SQRT(AY(8,1))+1.7
      IF(IRHO.NE.0) RHO0=RHO(ISOUR)
      RHEND=0.2*SQRT(AY(8,NN))+1.7
      IF(IRHO.NE.0) RHEND=RHO(LAY)
      AV=AV*Vp0*RHO0
      AV=AV/(VpEND*RHEND)
      UU=SQRT(ABS(AV*AL))
      IF(IAMP.GT.0)
     1WRITE(LOU,'(A,4F12.6)')' VP0,RH0,VPEND,RHEND',Vp0,RHO0,VpEND,RHEND
 130  CONTINUE
      AMPX(KSS)=UC(1)
      AMPY(KSS)=UC(2)
      AMPZ(KSS)=UC(3)
      IREF=IRE
      N=NN
      IF(ISHEAR.NE.0.AND.KSS.NE.2) THEN
        KSS=2
        ITP=2
        GOTO 3000
      END IF
      RETURN
      END