C
C *** DISPLACEMENTS AND TRACTIONS ALONG THE INTERFACE BETWEEN BEDROCK
C     AND SEDIMENTARY BASIN DOMAINS
C *** RECTANGULAR ELEMENT WITH CONSTANT DISPLACEMENT AND TRACTION
C *** EACH ELEMENT MUST BE WITHIN A LAYER
C


      PROGRAM BEM3A
C
      PARAMETER(MOM=30,MT=192)
      DIMENSION IP(MT)
      COMPLEX DUB(MT,MT),DPB(MT,MT),PS(MT),UU1(MT,MT)
     *   ,DUS(MT,MT),DPS(MT,MT),US(MT),UU2(MT,MT),U1(MT),U2(MT)
     *   ,UIS(MOM,MT),PIS(MOM,MT)
      COMPLEX X_PS(MT,MT),X_US(MT,MT)
      real tarray(2),utime

      COMMON /OMEGA/IOM,DOM,NOM /NELM/NEL,ND1(200),ND2(200),ND3(200)
       
C
      utime = dtime(tarray)
     
      CALL INDAT(MOM,MT)

      print *, 'NEL = ', NEL

      NC=200
      IF(NEL.GT.NC)THEN
        WRITE(1,*)'FROM MAIN: NEL.GT.NC !!',NEL,NC
        STOP
      END IF
C
      DO 100 IO=1,NOM
        OM=DOM*FLOAT(IOM+IO-1)
        CALL USPS(OM,MT,DUB,DPB,PS,DUS,DPS,US,UU1,UU2,U1,U2,IP)

        DO 110 I=1,3*NEL
          UIS(I,IO)=US(I)
          PIS(I,IO)=PS(I)
  110   CONTINUE
  100 CONTINUE
C
      CALL OUTDAT(MOM,MT,UIS,PIS)

      utime = dtime(tarray)
      print *, 'time = ', utime
C
      STOP
      END
C
C
C *** INPUT DATA ***
C
      SUBROUTINE INDAT(MOM,MT)
C
      COMMON /CHECK/NCK(10) /OMEGA/IOM,DOM,NOM /SIGN/ISIGN
C
      OPEN(7,FILE='input.data',STATUS='old')
C
C *** INPUT OF DATA FOR CHECK OUT ***
C
      READ(7,1000)(NCK(I),I=1,10)
 1000 FORMAT(/10I3)
      WRITE(1,2000)(NCK(I),I=1,10)
 2000 FORMAT(//' CHECK OUT =',10I3)
C
C *** INPUT OF OMEGA DATA ***
C
      READ(7,1100)IOM,NOM,DOM
 1100 FORMAT(///2I10,F10.0)
      WRITE(1,2100)IOM,NOM,DOM
 2100 FORMAT(//' IOM,NOM,DOM=',2I5,F8.4)
C
      IF(NOM.GT.MOM)THEN
        WRITE(1,*)' INDAT: NOM>MON !!'
        STOP
      END IF
C
C *** CHANGE OF SIGNS FOR IMAGINARY PARTS ***
C
      READ(7,1200)ISIGN
      IF(ISIGN.EQ.1)WRITE(1,2200)
      IF(ISIGN.EQ.0)WRITE(1,2210)
 1200 FORMAT(/I10)
 2200 FORMAT(//' SIGNS OF IMAGINARY PARTS FOR RESULTS ARE CHANGED')
 2210 FORMAT(//' SIGNS OF IMAGINARY PARTS FOR RESULTS ARE NOT CHANGED')
C
C *** INPUT OF MEDIUM DATA ***
C
      CALL INMED
C
C *** INPUT OF SEISMIC SOURCE DATA ***
C
      CALL INSRC
C
C *** INPUT OF INTEGRATION DATA ***
C
      CALL ININT
C
C *** INPUT OF NODE DATA ***
C
      CALL INNOD
C
C *** INPUT OF ELEMENT DATA ***
C
      CALL INELM(MT)
C
      CLOSE(7)
C
      RETURN
      END
C
C
C *** INPUT OF MEDIUM DATA ***
C
      SUBROUTINE INMED
C
      COMPLEX VPB,VSB,VPS,VSS
      COMMON /STRCB/NLB,DNSB(20),VPB(20),VSB(20),THB(20)
     *  /STRCS/NLS,DNSS(20),VPS(20),VSS(20),THS(20)
C
C *** PARAMETERS IN COMMOM ***
C
      ML=20
C
C *** INPUT BEDROCK DATA ***
C
      READ(7,1000)NLB
 1000 FORMAT(/I10)
C
      IF(NLB.GT.ML)THEN
        WRITE(1,*)'FROM INMED:NLB>ML !!'
        STOP
      END IF
C
      DO 100 IL=1,NLB
        READ(7,1100)DNSB(IL),VP,QP,VS,QS,THB(IL)
        VPB(IL)=VP*CMPLX(1.0,-0.5/QP)
        VSB(IL)=VS*CMPLX(1.0,-0.5/QS)
        IF(IL.EQ.NLB)THB(IL)=0.0
  100 CONTINUE
 1100 FORMAT(6F8.0)
C
C *** INPUT SEDIMENTARY BASIN DATA ***
C
      READ(7,1000)NLS
C
      IF(NLS.GT.ML)THEN
        WRITE(1,*)'FROM INMED:NLS>ML !!'
        STOP
      END IF
C
      DO 200 IL=1,NLS
        READ(7,1100)DNSS(IL),VP,QP,VS,QS,THS(IL)
        VPS(IL)=VP*CMPLX(1.0,-0.5/QP)
        VSS(IL)=VS*CMPLX(1.0,-0.5/QS)
        IF(IL.EQ.NLS)THS(IL)=0.0
  200 CONTINUE
C
C *** DATA OUTPUT ***
C
c      WRITE(1,2000)NLB
      DO 300 IL=1,NLB
        WRITE(1,2100)IL,DNSB(IL),VPB(IL),VSB(IL),THB(IL)
  300 CONTINUE
c 2000 FORMAT(//' Total Layers Number for the bedrock =',I5/
c     *       /' Layer Num., Density , Vp(real), Vp(imag)'
c     *        ', Vs(real), Vs(imag),Thickness')
 2100 FORMAT(I5,5X,6F10.3)
C
c      WRITE(1,2200)NLS
      DO 400 IL=1,NLS
        WRITE(1,2300)IL,DNSS(IL),VPS(IL),VSS(IL),THS(IL)
  400 CONTINUE
c 2200 FORMAT(/' Total Layers Number for the sediments =',I5/
c     *       /' Layer Num., Density , Vp(real), Vp(imag)'
c     *        ', Vs(real), Vs(imag),Thickness')
 2300 FORMAT(I5,5X,6F10.3)
C
      RETURN
      END
C
C
C *** INPUT OF SEISMIC SOURCE DATA ***
C
      SUBROUTINE INSRC
C
      COMPLEX VPB,VSB,VPS,VSS
      COMMON /FLTB/NFB,XFB(30),YFB(30),LFB(30),DEPB(30),STRB(30)
     *       ,DIPB(30),RAKB(30),FLB(30),FWB(30),FDB(30),RTB(30)
     *       ,VRB(30),NVRB(30),TDB(30)
     *       /FLTS/NFS,XFS(30),YFS(30),LFS(30),DEPS(30),STRS(30)
     *       ,DIPS(30),RAKS(30),FLS(30),FWS(30),FDS(30),RTS(30)
     *       ,VRS(30),NVRS(30),TDS(30) 
      COMMON /STRCB/NLB,DNSB(20),VPB(20),VSB(20),THB(20)
     *  /STRCS/NLS,DNSS(20),VPS(20),VSS(20),THS(20)
C
C *** PARAMETERS IN COMMOM ***
C
      MF=30
C
      NC=20
      IF(NLB.GE.NC)THEN
        WRITE(1,*)' FROM INSRC:NLB>NC !!!!!!!!!!'
        WRITE(1,*)' NLB,NC=',NLB,NC
        STOP
      END IF
      IF(NLS.GE.NC)THEN
        WRITE(1,*)' FROM INSRC:NLS>NC !!!!!!!!!!'
        WRITE(1,*)' NLS,NC=',NLS,NC
        STOP
      END IF
C
C *** SOURCE DATA FOR THE BEDROCK DOMAIN ***
C
      READ(7,1000)NFB
 1000 FORMAT(/I10)
C
      IF(NFB.GT.MF)THEN
        WRITE(1,*)' NFB.GT.MF !!!!!!'
        STOP
      END IF
C
      DO 100 I=1,NFB
C
        READ(7,1010)TDB(I)
        READ(7,1020)XFB(I),YFB(I)
        READ(7,1020)DEPB(I),STRB(I)
        READ(7,1020)DIPB(I),RAKB(I)
        STRB(I)=STRB(I)*0.01745329252
        DIPB(I)=DIPB(I)*0.01745329252
        RAKB(I)=RAKB(I)*0.01745329252
        READ(7,1030)FLB(I),FWB(I),FDB(I)
        READ(7,1020)RTB(I),VRB(I)
        READ(7,1040)NVRB(I)
C
        DRU=0.0
        DRL=THB(1)
        DO 110 L=1,NLB
          IF((DEPB(I).GE.DRU).AND.(DEPB(I).LT.DRL))LFB(I)=L
          IF((DEPB(I).GE.DRU).AND.(L.EQ.NLB))      LFB(I)=L
          DRU=DRL
          DRL=DRL+THB(L+1)
  110   CONTINUE
C
  100 CONTINUE
 1010 FORMAT(F10.0)
 1020 FORMAT(2F10.0)
 1030 FORMAT(3F10.0)
 1040 FORMAT(I10)
C
C *** SOURCE DATA FOR THE SEDIMENT DOMAIN ***
C
      READ(7,1000)NFS
C
      IF(NFS.GT.MF)THEN
        WRITE(1,*)' NFS.GT.MF !!!!!!'
        STOP
      END IF
C
      DO 200 I=1,NFS
C
        READ(7,1010)TDS(I)
        READ(7,1020)XFS(I),YFS(I)
        READ(7,1020)DEPS(I),STRS(I)
        READ(7,1020)DIPS(I),RAKS(I)
        STRS(I)=STRS(I)*0.01745329252
        DIPS(I)=DIPS(I)*0.01745329252
        RAKS(I)=RAKS(I)*0.01745329252
        READ(7,1030)FLS(I),FWS(I),FDS(I)
        READ(7,1020)RTS(I),VRS(I)
        READ(7,1040)NVRS(I)
C
        DRU=0.0
        DRL=THS(1)
        DO 210 L=1,NLS
          IF((DEPS(I).GE.DRU).AND.(DEPS(I).LT.DRL))LFS(I)=L
          IF((DEPS(I).GE.DRU).AND.(L.EQ.NLS))      LFS(I)=L
          DRU=DRL
          DRL=DRL+THS(L+1)
  210   CONTINUE
C
  200 CONTINUE
C
C *** OUTPUT ***
C
      WRITE(1,2000)NFB
      DO 300 I=1,NFB
      WRITE(1,2010)I
      WRITE(1,2020)XFB(I),YFB(I)
      WRITE(1,2030)DEPB(I),LFB(I)
      WRITE(1,2040)STRB(I),DIPB(I)
      WRITE(1,2050)RAKB(I)
      WRITE(1,2060)FLB(I),FWB(I)
      WRITE(1,2070)FDB(I),RTB(I)
      IF(NVRB(I).NE.1)THEN
        WRITE(1,2080)VRB(I)
      ELSE
        WRITE(1,2090)
      END IF
  300 CONTINUE
C
 2000 FORMAT(//' Source Data for the bedrock domain'
     *        '  : Number of Source =',I3)
 2010 FORMAT(/'   Source Number                            =',I5)
 2020 FORMAT(/'    Source X-Axis(m)=',F12.3,', Y-Axis (m)   =',F12.3)
 2030 FORMAT( '    Source Depth (m)=',F12.3,', Source Layer =',I5)
 2040 FORMAT( '    Strike Angle(rd)=',F12.8,', Dip Angle(rd)=',F12.8)
 2050 FORMAT( '    Rake Angle  (rd)=',F12.8)
 2060 FORMAT( '    Fault Length (m)=',F12.3,', Width(m)     =',F12.3)
 2070 FORMAT( '    Dislocation  (m)=',F12.5,', Rise Time(s) =',F12.8)
 2080 FORMAT( '    Rupture Velocity (m/s) =',F12.3)
 2090 FORMAT( '    Rupture Velocity (m/s) = Infinite ')
C
      WRITE(1,2100)NFS
      DO 400 I=1,NFS
      WRITE(1,2010)I
      WRITE(1,2020)XFS(I),YFS(I)
      WRITE(1,2030)DEPS(I),LFS(I)
      WRITE(1,2040)STRS(I),DIPS(I)
      WRITE(1,2050)RAKS(I)
      WRITE(1,2060)FLS(I),FWS(I)
      WRITE(1,2070)FDS(I),RTS(I)
      IF(NVRS(I).NE.1)THEN
        WRITE(1,2080)VRS(I)
      ELSE
        WRITE(1,2090)
      END IF
  400 CONTINUE
C
 2100 FORMAT(/' Source Data for the sedimentary basin'
     *        '  : Number of Source =',I3)
C
      RETURN
      END
C
C
C *** INPUT OF INTEGRATION DATA ***
C
      SUBROUTINE ININT
C
      COMMON /INTGB/C11B,N11B,C12B,N12B /IASYM/IST
     *   /INTG2B/I12B,WBB,N21B,WCB,N22B
     *  /INTGS/C11S,N11S,C12S,N12S /INTG2S/I12S,WBS,N21S,WCS,N22S
C
C *** WAVE NUMBER INTEGRATION DATA FOR BEDROCK ***
C
      READ(7,1000)I12B
      WRITE(1,2000)I12B
 1000 FORMAT(/I10)
 2000 FORMAT(//' INTEGRAL DATA FOR BEDROCK: PATTERN=',I5)
C
      IF(I12B.EQ.1)THEN
        READ(7,1100)C11B,N11B,C12B,N12B
        READ(7,*)
        WRITE(1,2100)C11B,N11B,C12B,N12B
        WRITE(1,2110)N11B*2+1,N12B*2+1
      ELSE
        READ(7,*)
        READ(7,1100)WBB,N21B,WCB,N22B
        WRITE(1,2120)WBB,N21B,WCB,N22B
        WRITE(1,2110)N21B*2+1,N22B*2+1
      END IF
C
 1100 FORMAT(F10.0,I10,F10.0,I10)
 2100 FORMAT(/'  C1,N1,C2,N2=',F10.2,I5,F10.2,I5)
 2110 FORMAT( '  ACTUAL INTEGRAL POINTS FOR N1 AND N2=',2I5)
 2120 FORMAT(/'  WNB,N1,WNC,N2=',F10.7,I5,F10.7,I5)
C
C *** WAVE NUMBER INTEGRATION DATA FOR SEDIMENTS ***
C
      READ(7,1000)I12S
      WRITE(1,2200)I12S
 2200 FORMAT(/' INTEGRAL DATA FOR SEDIMENTS: PATTERN=',I5)
C
      IF(I12S.EQ.1)THEN
        READ(7,1100)C11S,N11S,C12S,N12S
        READ(7,*)
        WRITE(1,2100)C11S,N11S,C12S,N12S
        WRITE(1,2110)N11S*2+1,N12S*2+1
      ELSE
        READ(7,*)
        READ(7,1100)WBS,N21S,WCS,N22S
        WRITE(1,2120)WBS,N21S,WCS,N22S
        WRITE(1,2110)N21S*2+1,N22S*2+1
      END IF
C
C *** ASYMPTOTIC TECHNIQUE ***
C
      READ(7,1600)IST
      IF(IST.EQ.1)THEN
        WRITE(1,2600)
      ELSE
        WRITE(1,2610)
      END IF
 1600 FORMAT(/I10)
 2600 FORMAT(//' THE ASYMPTOTIC METHOD IS USED')
 2610 FORMAT(//' THE ASYMPTOTIC METHOD IS NOT USED')
C
      RETURN
      END
C
C
C *** INPUT OF NODE DATA ***
C
      SUBROUTINE INNOD
C
      COMMON /NODE/NND,XND(200),YND(200),ZND(200) 
C
C *** PARAMETERS IN COMMOM ***
C
      MND=200
C
C *** INPUT ***
C
      READ(7,1000)NND
 1000 FORMAT(/I10)
C
      IF(NND.GT.MND)THEN
        WRITE(1,*)'FROM INNOD: NND>MND !!!',NND,MND
        STOP
      END IF
C
      WRITE(1,2000)NND
 2000 FORMAT(//' TOTAL NODE NUMBER =',I5/)
C
      DO 100 I=1,NND
      READ(7,1100)XND(I),YND(I),ZND(I)
  100 CONTINUE
 1100 FORMAT(3F10.0)
C
      DO 200 I=1,NND,2
      WRITE(1,2100)XND(I),YND(I),ZND(I)
     *            ,XND(I+1),YND(I+1),ZND(I+1)
  200 CONTINUE
 2100 FORMAT(' 2*(X,Y,Z)=',3E11.3,2X,3E11.3)
C
      RETURN
      END
C
C
C *** INPUT OF ELEMENT DATA ***
C
      SUBROUTINE INELM(MT)
C
      COMMON /NODE/NND,XND(200),YND(200),ZND(200) 
     *  /NELM/NEL,ND1(200),ND2(200),ND3(200)
     */ELEM/XN(200),YN(200),ZN(200),S1(200),S2(200),S3(200),ANG(200)
C
C *** PARAMETERS IN COMMOM ***
C
      MEL=200
C
      NC=200
      IF(NND.GE.NC)THEN
        WRITE(1,*)' FROM INELM:NND>NC !!!!!!!!!!'
        WRITE(1,*)' NND,NC=',NND,NC
        STOP
      END IF
C
C *** INPUT OF ELEMENT DATA ***
C
      READ(7,1000)NEL
      WRITE(1,2000)NEL
 1000 FORMAT(/I10)
 2000 FORMAT(//' TOTAL ELEMENT NUMBER =',I5)
C
      IF(NEL.GT.MEL)THEN
        WRITE(1,*)'FROM INELM: NEL>MEL !!',NEL,MEL
        STOP
      END IF
C
      IF(NEL*3.GT.MT)THEN
        WRITE(1,*)'FROM INELM: NEL*3>MT !!',NEL*3,MT
        STOP
      END IF
C
      DO 100 I=1,NEL,3
      READ(7,1100)ND1(I),ND2(I),ND3(I),ND1(I+1),ND2(I+1),ND3(I+1)
     *           ,ND1(I+2),ND2(I+2),ND3(I+2)
  100 CONTINUE
 1100 FORMAT(3I4,4X,3I4,4X,3I4)
C
C *** ELEMENT DATA ***
C
      WRITE(1,2200)
      DO 200 I=1,NEL
C
        N1=ND1(I)
        N2=ND2(I)
        N3=ND3(I)
        X1=XND(N1)
        X2=XND(N2)
        X3=XND(N3)
        Y1=YND(N1)
        Y2=YND(N2)
        Y3=YND(N3)
        Z1=ZND(N1)
        Z2=ZND(N2)
        Z3=ZND(N3)
C       
        S1(I)=SQRT((X2-X3)*(X2-X3)+(Y2-Y3)*(Y2-Y3)+(Z2-Z3)*(Z2-Z3))
        S2(I)=SQRT((X3-X1)*(X3-X1)+(Y3-Y1)*(Y3-Y1)+(Z3-Z1)*(Z3-Z1))
        S3(I)=SQRT((X1-X2)*(X1-X2)+(Y1-Y2)*(Y1-Y2)+(Z1-Z2)*(Z1-Z2))
        ANG(I)=ACOS((S2(I)*S2(I)+S3(I)*S3(I)-S1(I)*S1(I))
     *              /(2.0*S2(I)*S3(I)))
        ANG2  =ACOS((S3(I)*S3(I)+S1(I)*S1(I)-S2(I)*S2(I))
     *              /(2.0*S3(I)*S1(I)))
        ANG3  =ACOS((S1(I)*S1(I)+S2(I)*S2(I)-S3(I)*S3(I))
     *              /(2.0*S1(I)*S2(I)))

C
        A1=X2-X1
        A2=Y2-Y1
        A3=Z2-Z1
        B1=X3-X1
        B2=Y3-Y1
        B3=Z3-Z1
        X=A2*B3-A3*B2
        Y=A3*B1-A1*B3
        Z=A1*B2-A2*B1
        A=SQRT(X*X+Y*Y+Z*Z)
        XN(I)=X/A
        YN(I)=Y/A
        ZN(I)=Z/A
C
        XS=(X1+X2+X3)/3.0
        YS=(Y1+Y2+Y3)/3.0
        ZS=(Z1+Z2+Z3)/3.0
        PT=57.2957795
        WRITE(1,2210)I,ND1(I),ND2(I),ND3(I)
        WRITE(1,2220)XN(I),YN(I),ZN(I)
        WRITE(1,2230)S1(I),S2(I),S3(I)
        WRITE(1,2240)ANG(I)*PT,ANG2*PT,ANG3*PT
        WRITE(1,2250)XS,YS,ZS
C
  200 CONTINUE
C
 2200 FORMAT(/' ELEMENT DATA:',
     *       /' NODE NUMBER MUST BE CLOCKWISE FROM BASIN DOMAIN !!'/)
 2210 FORMAT(' ELEMENT NUMBER AND NODE NUMBER     =',I4,4X,4I4)
 2220 FORMAT(' OUTWARD NORMAL VECTORS (FROM BASIN)=',3e12.4)
 2230 FORMAT(' LENGHTS OF SIDES                   =',3e12.4)
 2240 FORMAT(' ANGEL OF APEX 1, 2 AND 3 (DEGREE)  =',3F12.5)
 2250 FORMAT(' LOCATION OF SOURCE POINT (X,Y,Z)   =',3F12.4)
C
      RETURN
      END
C
C
C *** OUTPUT OF DISPLACEMENT AND TRACTION ALONG THE INTERFACE ***
C
      SUBROUTINE OUTDAT(MOM,MT,U,P)
      COMPLEX U(MOM,MT),P(MOM,MT)
      COMMON /OMEGA/IOM,DOM,NOM /NELM/NEL,ND1(200),ND2(200),ND3(200)
C
      NC=200
      IF(NEL.GE.NC)THEN
        WRITE(1,*)' FROM OUTDAT:NEL>NC !!!!!!!!!!'
        WRITE(1,*)' NEL,NC=',NEL,NC
        STOP
      END IF
C
      DO 100 I=1,NOM
      DO 110 J=1,3*NEL,3
      WRITE(11,1000)U(J,I),U(J+1,I),U(J+2,I)
  110 CONTINUE
      DO 120 J=1,3*NEL,3
      WRITE(11,1000)P(J,I),P(J+1,I),P(J+2,I)
  120 CONTINUE
  100 CONTINUE
 1000 FORMAT(6E13.6)
C
      RETURN
      END
C
C
C *** THE DISPLACEMENTS AND TRACTIONS VECTORS AT NODES ALONG THE INTEFACE ***
C
      SUBROUTINE USPS(OM,MT,DUB,DPB,UFB,DUS,DPS,UFS
     *               ,UU1,UU2,U1,U2,IP)
C
      DIMENSION IP(MT)
      COMPLEX DUB(MT,MT),DPB(MT,MT),UFB(MT),UU1(MT,MT),U1(MT)
     *   ,DUS(MT,MT),DPS(MT,MT),UFS(MT),UU2(MT,MT),DET,U2(MT)
     *   ,VP,VS,VPB,VSB,VPS,VSS

      COMMON /NODE/NND,XND(200),YND(200),ZND(200) 
     *  /NELM/NEL,ND1(200),ND2(200),ND3(200)
     */ELEM/XN(200),YN(200),ZN(200),S1(200),S2(200),S3(200),ANG(200)
     *  /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *  /STRCB/NLB,DNSB(20),VPB(20),VSB(20),THB(20)
     *  /STRCS/NLS,DNSS(20),VPS(20),VSS(20),THS(20)
     *  /INTG/C11,N11,C12,N12 /INTG2/I12,WNB,N21,WNC,N22
     *  /INTGB/C11B,N11B,C12B,N12B /INTG2B/I12B,WBB,N21B,WCB,N22B
     *  /INTGS/C11S,N11S,C12S,N12S /INTG2S/I12S,WBS,N21S,WCS,N22S
     *  /FLT/NF,XF(30),YF(30),LF(30),DEP(30),STR(30),DIP(30),RAK(30)
     *      ,FL(30),FW(30),FD(30),RT(30),VR(30),NVR(30),TD(30) 
     *  /FLTB/NFB,XFB(30),YFB(30),LFB(30),DEPB(30),STRB(30),DIPB(30)
     *       ,RAKB(30),FLB(30),FWB(30),FDB(30),RTB(30),VRB(30)
     *       ,NVRB(30),TDB(30) 
     *  /FLTS/NFS,XFS(30),YFS(30),LFS(30),DEPS(30),STRS(30),DIPS(30)
     *       ,RAKS(30),FLS(30),FWS(30),FDS(30),RTS(30),VRS(30)
     *       ,NVRS(30),TDS(30) 
     *  /CHECK/NCK(10)

C
C *** CHECK OF DIMENSION ***
C
      NC=200
      IF(NND.GE.NC)THEN
        WRITE(1,*)' FROM USPS:NND>NC !!!!!!!!!!'
        WRITE(1,*)' NND,NC=',NND,NC
        STOP
      END IF
C
      NC=200
      IF(NEL.GE.NC)THEN
        WRITE(1,*)' FROM USPS:NEL>NC !!!!!!!!!!'
        WRITE(1,*)' NEL,NC=',NEL,NC
        STOP
      END IF
C
      NC=20
      IF(NLB.GE.NC)THEN
        WRITE(1,*)' FROM USPS:NLB>NC !!!!!!!!!!'
        WRITE(1,*)' NLB,NC=',NLB,NC
        STOP
      END IF
C
      NC=20
      IF(NLS.GE.NC)THEN
        WRITE(1,*)' FROM USPS:NLS>NC !!!!!!!!!!'
        WRITE(1,*)' NLS,NC=',NLS,NC
        STOP
      END IF
C
      NC=30
      IF(NFB.GE.NC)THEN
        WRITE(1,*)' FROM USPS:NFB>NC !!!!!!!!!!'
        WRITE(1,*)' NFB,NC=',NFB,NC
        STOP
      END IF
C
      NC=30
      IF(NFS.GE.NC)THEN
        WRITE(1,*)' FROM USPS:NFS>NC !!!!!!!!!!'
        WRITE(1,*)' NFS,NC=',NFS,NC
        STOP
      END IF
C
C *** MATRIX AND INCIDENT WAVE FOR BEDROCK DOMAIN ***
C
      NL=NLB
      DO 100 I=1,NL
        DNS(I)=DNSB(I)
        VP(I) =VPB(I)
        VS(I) =VSB(I)
        THK(I)=THB(I)
  100 CONTINUE
C
      I12=I12B
      IF(I12.EQ.1)THEN
        C11=C11B
        N11=N11B
        C12=C12B
        N12=N12B
      ELSE
        WNB=WBB
        N21=N21B
        WNC=WCB
        N22=N22B
      END IF
C
      DO 120 I=1,NEL
        XN(I)=-XN(I)
        YN(I)=-YN(I)
        ZN(I)=-ZN(I)
  120 CONTINUE
C
      NF=NFB
      DO 150 I=1,NF
        XF(I) =XFB(I)
        YF(I) =YFB(I)
        LF(I) =LFB(I)
        DEP(I)=DEPB(I)
        STR(I)=STRB(I)
        DIP(I)=DIPB(I)
        RAK(I)=RAKB(I)
        FL(I) =FLB(I)
        FW(I) =FWB(I)
        FD(I) =FDB(I)
        RT(I) =RTB(I)
        VR(I) =VRB(I)
        NVR(I)=NVRB(I)
        TD(I) =TDB(I)
  150 CONTINUE
c
      print *, ' 1st  call to dudpf, NEL = ', NEL
      CALL DUDPF(OM,MT,DUB,DPB,UFB,1)

C
C *** MATRIX AND INCIDENT WAVE FOR SEDIEMNTARY BASIN DOMAIN ***
C
      NL=NLS
      DO 200 I=1,NL
        DNS(I)=DNSS(I)
        VP(I) =VPS(I)
        VS(I) =VSS(I)
        THK(I)=THS(I)
  200 CONTINUE
C
      I12=I12S
      IF(I12.EQ.1)THEN
        C11=C11S
        N11=N11S
        C12=C12S
        N12=N12S
      ELSE
        WNB=WBS
        N21=N21S
        WNC=WCS
        N22=N22S
      END IF
C
      DO 220 I=1,NEL
        XN(I)=-XN(I)
        YN(I)=-YN(I)
        ZN(I)=-ZN(I)
  220 CONTINUE
C
      NF=NFS
      DO 250 I=1,NF
        XF(I) =XFS(I)
        YF(I) =YFS(I)
        LF(I) =LFS(I)
        DEP(I)=DEPS(I)
        STR(I)=STRS(I)
        DIP(I)=DIPS(I)
        RAK(I)=RAKS(I)
        FL(I) =FLS(I)
        FW(I) =FWS(I)
        FD(I) =FDS(I)
        RT(I) =RTS(I)
        VR(I) =VRS(I)
        NVR(I)=NVRS(I)
        TD(I) =TDS(I)
  250 CONTINUE

C
      print *, ' 2nd call to dudpf'

      CALL DUDPF(OM,MT,DUS,DPS,UFS,2)

C
C *** CHECK (NCK(4)=1) ***
C      
      NT=NEL*3

C
c      IF(NCK(4).EQ.1)THEN
C
c      WRITE(1,*)
c      WRITE(1,*)' DUS-DUB'
c      DO 801 I=1,NT
c      DO 801 J=1,NT,3
c        WRITE(2,1000)DUS(I,J)-DUB(I,J),DUS(I,J+1)-DUB(I,J+1)
c     *              ,DUS(I,J+2)-DUB(I,J+2)
c 801  CONTINUE
      
c      
c      WRITE(1,*)
c      WRITE(1,*)' DIAGONAL DPS+DPB'
c      DO 802 I=1,NEL
c      WRITE(1,*)'ELEM =',I
c      DO 802 J=1,3
c      WRITE(1,2)DPS(3*(I-1)+J,3*(I-1)+1)+DPB(3*(I-1)+J,3*(I-1)+1)
c     *         ,DPS(3*(I-1)+J,3*(I-1)+2)+DPB(3*(I-1)+J,3*(I-1)+2)
c     *         ,DPS(3*(I-1)+J,3*(I-1)+3)+DPB(3*(I-1)+J,3*(I-1)+3)
c 802  CONTINUE
c 2    FORMAT(6E12.4)
C
c      END IF
C
C *** US(UFS) AND PS(UFB) ***

      DMX=0.0
      DO 500 I=1,NT
        DO 510 J=1,NT
          DTM=CABS(DPB(I,J))
          IF(DTM.GT.DMX)DMX=DTM
  510   CONTINUE
  500 CONTINUE
C
      EPS=DMX*1.E-14
      CALL DCINV(DPB,NT,0,MT,MT,EPS,DET,U1,IP,NSTOP)
C      CALL CGETRF(NT,NT,DPB,MT,IP,NSTOP)
C      IF(NSTOP.NE.0)THEN
C        WRITE(10,*)' CGETRF DPB: NSTOP=',NSTOP,'!!!!!!!!!!!!!!'
C        STOP
C      END IF
C      CALL CGETRI(NT,DPB,MT,IP,U2,MT,NSTOP)
      IF(NSTOP.NE.0)THEN
        WRITE(10,*)' CGETRI DPB: NSTOP=',NpSTOP,'!!!!!!!!!!!!!!'
        STOP
      END IF

      DO 550 I=1,NT
        U2(I)=(0.0,0.0)
        DO 560 J=1,NT
          U2(I)=U2(I)+DPB(I,J)*UFB(J)
          UU2(I,J)=(0.0,0.0)
          DO 570 K=1,NT
            UU2(I,J)=UU2(I,J)+DPB(I,K)*DUB(K,J)
  570     CONTINUE
  560   CONTINUE
  550 CONTINUE
C
      DO 600 I=1,NT
        UFB(I)=-UFS(I)
        DO 610 J=1,NT
          UFB(I)=UFB(I)+DPS(I,J)*U2(J)
          UU1(I,J)=DUS(I,J)
          DO 620 K=1,NT
            UU1(I,J)=UU1(I,J)+DPS(I,K)*UU2(K,J)
  620     CONTINUE
  610   CONTINUE
  600 CONTINUE
C
      DO 650 I=1,NT
        DMX=CABS(UU1(I,1))
        DO 660 J=2,NT
          DTM=CABS(UU1(I,J))
          IF(DTM.GT.DMX)DMX=DTM
  660   CONTINUE
        UFB(I)=UFB(I)/DMX
C        DPB(I,1)=UFB(I)/DMX
        DO 670 J=1,NT
          UU1(I,J)=UU1(I,J)/DMX
  670   CONTINUE
  650 CONTINUE
C
      EPS=1.E-14
      CALL DCLNLU(UU1,NT,MT,UFB,EPS,U1,IP,NSTOP)
C      CALL CGESV(NT,1,UU1,MT,IP,DPB,MT,NSTOP)
      IF(NSTOP.NE.0)THEN
        WRITE(10,*)' CGESV UU1: NSTOP=',NSTOP,'!!!!!!!!!!!!!!'
        STOP
      END IF
C
      DO 700 I=1,NT
        UFS(I)=U2(I)
C        UFB(I)=DPB(I,1)
        DO 710 J=1,NT
          UFS(I)=UFS(I)-UU2(I,J)*UFB(J)
C          UFS(I)=UFS(I)-UU2(I,J)*DPB(J,1)
  710   CONTINUE
  700 CONTINUE
C
C *** CHECK OUT (NCK(1)=1) ***
C
      IF(NCK(1).EQ.1)THEN
        WRITE(1,*)
        WRITE(1,*)'CHECK OUT FROM USPS (NCK(1)=1) !!!!'
        WRITE(1,*)' US(UFS)=(X,Y,Z)'
        DO 800 I=1,NT,3
        WRITE(1,1000)UFS(I),UFS(I+1),UFS(I+2)
  800   CONTINUE
        WRITE(1,*)' PS(UFB)=(X,Y,Z)'
        DO 810 I=1,NT,3
        WRITE(1,1000)UFB(I),UFB(I+1),UFB(I+2)
  810   CONTINUE
 1000   FORMAT(6E12.4)
      END IF
c
      RETURN
      END
C
C *** THE 3N*3N MATRIX OF THE DISPLACEMENT AND TRACTION GREEN 
C     FUNCTIONS FOR THE BEDROCK OR SEDIMENTARY BASIN DOMAINS
C
      SUBROUTINE DUDPF(OM,MT,DU,DP,UF,IBS)
C
      COMPLEX DU(MT,MT),DCS(3,3),DP(MT,MT),VP,VS,UF(MT),EU(3,3)
     *     ,SM1,XX1,SM2,XX2,SM3,XX3,RM1,RM2,RM3,VS2,VP2,EP(3,3)


      COMMON /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *  /NODE/NND,XND(200),YND(200),ZND(200)
     *  /NELM/NEL,ND1(200),ND2(200),ND3(200) 
     */ELEM/XN(200),YN(200),ZN(200),S1(200),S2(200),S3(200),ANG(200)
     *  /DPSO /DEP1,DEP2,ZS,ZO /SOLY/LS,SDEP,LO,ODEP
     *  /ASYMP/SM1,XX1,SM2,XX2,SM3,XX3 /RAM/RM1,RM2,RM3
     *  /INTG/C11,N11,C12,N12 /INTG2/I12,WNB2,N21,WNC2,N22
     *  /FLT/NF,XF(30),YF(30),LF(30),DEP(30),STR(30),DIP(30),RAK(30)
     *      ,FL(30),FW(30),FD(30),RT(30),VR(30),NVR(30),TD(30) 
     *  /CHECK/NCK(10)
C
C *** CHECK OF DIMENSION ***
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM DUDPF:NL>NC !!!!!!!!!!'
       WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
      NC=200
      IF(NND.GE.NC)THEN
        WRITE(1,*)' FROM DUDPF:NND>NC !!!!!!!!!!'
        WRITE(1,*)' NND,NC=',NND,NC
        STOP
      END IF
C
      NC=200
      IF(NEL.GE.NC)THEN
        WRITE(1,*)' FROM DUDPF:NEL>NC !!!!!!!!!!'
        WRITE(1,*)' NEL,NC=',NEL,NC
        STOP
      END IF
C
      NC=30
      IF(NF.GE.NC)THEN
        WRITE(1,*)' FROM DUDPF:NF>NC !!!!!!!!!!'
        WRITE(1,*)' NF,NC=',NF,NC
        STOP
      END IF
C
C *** MATRIX ***

C      pdo iis = 1, NEL*3

       do is = 1, NEL

        print *, ' is = ', is
C
C     * SOURCE *
C
        Z1=ZND(ND1(IS))
        Z2=ZND(ND2(IS))
        Z3=ZND(ND3(IS))
        ZS=(Z1+Z2+Z3)/3.0
C
        DRU=0.0
        DRL=THK(1)
        DO 110 L=1,NL
          IF((ZS.GE.DRU).AND.(ZS.LT.DRL))LS=L
          IF((ZS.GE.DRU).AND.(L.EQ.NL))LS=L
          DRU=DRL
          DRL=DRL+THK(L+1)
  110   CONTINUE
C
        VS2= VS(LS)*VS(LS)
        SM2= DNS(LS)*VS2
        VP2= VP(LS)*VP(LS)
        RM2= DNS(LS)*VP2-2.0*SM2
        XX2= (1.0+VS2/VP2)/(1.0-VS2/VP2)
C
C     * COEFFICIENT FOR THE SOURCE NODE *
C
        CALL DCSUP(IS,DCS,IBS)
C
        DO 130 I=1,3
        DO 130 J=1,3
          DP(3*(IS-1)+I,3*(IS-1)+J)
     *              =DP(3*(IS-1)+I,3*(IS-1)+J)+DCS(I,J)
  130   CONTINUE
C
C *** UP/DOWN-GOING R/T COEFFICIENTS ***
c
        DEP1=0.0
        DO 120 L=1,LS-1
          DEP1=DEP1+THK(L)
  120   CONTINUE
        SDEP=ZS-DEP1
        DEP2=DEP1+THK(LS)
C
        IF(LS.GE.2)THEN
          VS2= VS(LS-1)*VS(LS-1)
          SM1= DNS(LS-1)*VS2
          VP2= VP(LS-1)*VP(LS-1)
          RM1= DNS(LS-1)*VP2-2.0*SM1
          XX1 = (1.0+VS2/VP2)/(1.0-VS2/VP2)
        END IF
        IF(LS.NE.NL)THEN
          VS2= VS(LS+1)*VS(LS+1)
          SM3= DNS(LS+1)*VS2
          VP2= VP(LS+1)*VP(LS+1)
          RM3= DNS(LS+1)*VP2-2.0*SM3
          XX3 = (1.0+VS2/VP2)/(1.0-VS2/VP2)
        END IF
C
        IF(I12.EQ.1)THEN
          N1=N11
          N2=N12
          WNB=OM/C12
          WNA=WNB/(1000.0*N1)
          WNC=OM/C11
        ELSE
          N1=N21
          N2=N22
          WNB=WNB2
          WNA=WNB/(1000.0*N1)
          WNC=WNC2
        END IF
C
        CALL CUDSH(OM,WNA,WNB,N1,1)
        CALL CUDPSV(OM,WNA,WNB,N1,1)
        CALL CUDSH(OM,WNB,WNC,N2,2)
        CALL CUDPSV(OM,WNB,WNC,N2,2)
C
C     * ELEMENT *
C
        DO 150 IE=1,NEL
C
          XNRM=XN(IE)
          YNRM=YN(IE)
          ZNRM=ZN(IE)
          SL1=S1(IE)
          SL2=S2(IE)
          SL3=S3(IE)
C
          IF(IS.EQ.IE)THEN
           CALL DUPE(OM,IS,IE,XNRM,YNRM,ZNRM,SL1,SL2,SL3,EU,EP)
          ELSE
           AN=ANG(IE)
           CALL DUPN(OM,IS,IE,XNRM,YNRM,ZNRM,SL2,SL3,AN,EU,EP)
          END IF
C
          DO 160 I=1,3
          DO 160 J=1,3
            DU(3*(IS-1)+I,3*(IE-1)+J)
     *                =DU(3*(IS-1)+I,3*(IE-1)+J)+EU(I,J)
            DP(3*(IS-1)+I,3*(IE-1)+J)
     *                =DP(3*(IS-1)+I,3*(IE-1)+J)+EP(I,J)
  160     CONTINUE
C
  150   CONTINUE
c
        IF(NF.NE.0) then
          CALL FLU(OM,MT,IS,UF)
        endif

      enddo

C
C *** CHECK OUT (NCK(3)=1) ***
C
      IF(NCK(3).EQ.1)THEN
      WRITE(1,*)
      WRITE(1,*)'CHECK OUT FROM DUDPF (NCK(3)=1)'
      WRITE(1,*)' DU=(X,Y,Z)'
      DO 200 I=1,3*NEL
      DO 200 J=1,3*NEL,3
      WRITE(1,1000)DU(I,J),DU(I,J+1),DU(I,J+2)
  200 CONTINUE
      WRITE(1,*)' DP=(X,Y,Z)'
      DO 210 I=1,3*NEL
      DO 210 J=1,3*NEL,3
      WRITE(1,1000)DP(I,J),DP(I,J+1),DP(I,J+2)
  210 CONTINUE
      END IF
 1000 FORMAT(6E12.4)
C
C *** CHECK OUT (NCK(2))=1) ***
C
      IF(NCK(2).EQ.1)THEN
        WRITE(1,*)
        WRITE(1,*)'CHECK OUT FROM DUDPF (NCK(2)=1)'
        WRITE(1,*)' UF = (X,Y,Z)'
        DO 300 I=1,3*NEL,3
        WRITE(1,1000)UF(I),UF(I+1),UF(I+2)
  300   CONTINUE
      END IF
C
      RETURN
      END
C
C
C *** THE 3*3 SUPPLEMENTARY COEFFICIENT  MATRIX OF THE DIRECT TRACTION 
C     GREEN FUNCTIONS FOR THE FREE-TERM COEFFICIENTS FOR SORCE ELEMENT ***
C
      SUBROUTINE DCSUP(IS,DCS,IBS)
C
      DIMENSION R(15,15),B(15,15)
      COMPLEX DPA(3,3),DCS(3,3),VS,VP
      COMMON /NODE/NND,XND(200),YND(200),ZND(200)
     *    /NELM/NEL,ND1(200),ND2(200),ND3(200)
     */ELEM/XN(200),YN(200),ZN(200),S1(200),S2(200),S3(200),ANG(200)
     *    /DPSO /DEP1,DEP2,ZS,ZO /SOLY/LS,SDEP,LO,ODEP
     *    /CPASY/XS,YS,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3
     *    /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /CHECK/NCK(10)
C
C *** CHECK OF DIMENSION ***
C
      MSE=20
C
      NC=200
      IF(NND.GE.NC)THEN
        WRITE(1,*)' FROM DCSUP:NND>NC !!!!!!!!!!'
        WRITE(1,*)' NND,NC=',NND,NC
        STOP
      END IF
C
      NC=200
      IF(NEL.GE.NC)THEN
        WRITE(1,*)' FROM DCSUP:NEL>NC !!!!!!!!!!'
        WRITE(1,*)' NEL,NC=',NEL,NC
        STOP
      END IF
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM DCSUP:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
C *** LOCATION AND WEIGHT FOR GAUSS QUADRATURE ***
C
      NG=15
C
      R(1,1)=-0.9879925180205
      R(2,1)=-0.9372733924007
      R(3,1)=-0.8482065834104
      R(4,1)=-0.7244177313602
      R(5,1)=-0.5709721726085
      R(6,1)=-0.3941513470776
      R(7,1)=-0.2011940939974
      R(8,1)= 0.0
      R(9,1)= 0.2011940939974
      R(10,1)=0.3941513470776
      R(11,1)=0.5709721726085
      R(12,1)=0.7244177313602
      R(13,1)=0.8482065834104
      R(14,1)=0.9372733924007
      R(15,1)=0.9879925180205

      R(1,2)=-0.9862838086968
      R(2,2)=-0.9284348836636
      R(3,2)=-0.8272013150698
      R(4,2)=-0.6872929048117
      R(5,2)=-0.5152486363582
      R(6,2)=-0.3191123689279
      R(7,2)=-0.1080549487073
      R(8,2)= 0.1080549487073
      R(9,2)= 0.3191123689279
      R(10,2)=0.5152486363582
      R(11,2)=0.6872929048117
      R(12,2)=0.8272013150698
      R(13,2)=0.9284348836636
      R(14,2)=0.9862838086968

      R(1,3)=-0.9841830547186
      R(2,3)=-0.9175983992230
      R(3,3)=-0.8015780907333
      R(4,3)=-0.6423493394403
      R(5,3)=-0.4484927510364
      R(6,3)=-0.2304583159551
      R(7,3)= 0.0
      R(8,3)= 0.2304583159551
      R(9,3)= 0.4484927510364
      R(10,3)=0.6423493394403
      R(11,3)=0.8015780907333
      R(12,3)=0.9175983992230
      R(13,3)=0.9841830547186

      R(1,4)=-0.9815606342467
      R(2,4)=-0.9041172563705
      R(3,4)=-0.7699026741943
      R(4,4)=-0.5873179542866
      R(5,4)=-0.3678314989982
      R(6,4)=-0.1252334085115
      R(7,4)= 0.1252334085115
      R(8,4)= 0.3678314989982
      R(9,4)= 0.5873179542866
      R(10,4)=0.7699026741943
      R(11,4)=0.9041172563705
      R(12,4)=0.9815606342467

      R(1,5)=-0.9782286581461
      R(2,5)=-0.8870625997681
      R(3,5)=-0.7301520055740
      R(4,5)=-0.5190961292068
      R(5,5)=-0.2695431559523
      R(6,5)= 0.0
      R(7,5)= 0.2695431559523
      R(8,5)= 0.5190961292068
      R(9,5)= 0.7301520055740
      R(10,5)=0.8870625997681
      R(11,5)=0.9782286581461

      R(1,6)=-0.9739065285172
      R(2,6)=-0.8650633666890
      R(3,6)=-0.6794095682990
      R(4,6)=-0.4333953941292
      R(5,6)=-0.1488743389816
      R(6,6)= 0.1488743389816
      R(7,6)= 0.4333953941292
      R(8,6)= 0.6794095682990
      R(9,6)= 0.8650633666890
      R(10,6)=0.9739065285172

      R(1,7)=-0.9681602395076
      R(2,7)=-0.8360311073266
      R(3,7)=-0.6133714327006
      R(4,7)=-0.3242534234038
      R(5,7)= 0.0
      R(6,7)= 0.3242534234038
      R(7,7)= 0.6133714327006
      R(8,7)= 0.8360311073266
      R(9,7)= 0.9681602395076

      R(1,8)=-0.9602898564975
      R(2,8)=-0.7966664774136
      R(3,8)=-0.5255324099163
      R(4,8)=-0.1834346424956
      R(5,8)= 0.1834346424956
      R(6,8)= 0.5255324099163
      R(7,8)= 0.7966664774136
      R(8,8)= 0.9602898564975

      R(1,9)=-0.9491079123428
      R(2,9)=-0.7415311855994
      R(3,9)=-0.4058451513774
      R(4,9)= 0.0
      R(5,9)= 0.4058451513774
      R(6,9)= 0.7415311855994
      R(7,9)= 0.9491079123428

      R(1,10)=-0.9324695142032
      R(2,10)=-0.6612093864663
      R(3,10)=-0.2386191860832
      R(4,10)= 0.2386191860832
      R(5,10)= 0.6612093864663
      R(6,10)= 0.9324695142032

      R(1,11)=-0.9061798459387
      R(2,11)=-0.5384693101057
      R(3,11)= 0.0
      R(4,11)= 0.5384693101057
      R(5,11)= 0.9061798459387

      R(1,12)=-0.8611363115941
      R(2,12)=-0.3399810435849
      R(3,12)= 0.3399810435849
      R(4,12)= 0.8611363115941

      R(1,13)=-0.7745966692415
      R(2,13)= 0.0            
      R(3,13)= 0.7745966692415

      R(1,14)=-0.5773502691897
      R(2,14)= 0.5773502691897

      R(1,15)=0.0
C
      B(1,1)= 0.0307532419961
      B(2,1)= 0.0703660474881
      B(3,1)= 0.1071592204672
      B(4,1)= 0.1395706779261
      B(5,1)= 0.1662692058170
      B(6,1)= 0.1861610000156
      B(7,1)= 0.1984314853271
      B(8,1)= 0.2025782419256
      B(9,1)= 0.1984314853271
      B(10,1)=0.1861610000156
      B(11,1)=0.1662692058170
      B(12,1)=0.1395706779261
      B(13,1)=0.1071592204672
      B(14,1)=0.0703660474881
      B(15,1)=0.0307532419961

      B(1,2)= 0.0351194603318
      B(2,2)= 0.0801580871598
      B(3,2)= 0.1215185706879
      B(4,2)= 0.1572031671582
      B(5,2)= 0.1855383974779
      B(6,2)= 0.2051984637213
      B(7,2)= 0.2152638534632
      B(8,2)= 0.2152638534632
      B(9,2)= 0.2051984637213
      B(10,2)=0.1855383974779
      B(11,2)=0.1572031671582
      B(12,2)=0.1215185706879
      B(13,2)=0.0801580871598
      B(14,2)=0.0351194603318

      B(1,3)= 0.0404840047653
      B(2,3)= 0.0921214998377
      B(3,3)= 0.1388735102198
      B(4,3)= 0.1781459807619
      B(5,3)= 0.2078160475369
      B(6,3)= 0.2262831802629
      B(7,3)= 0.2325515532309
      B(8,3)= 0.2262831802629
      B(9,3)= 0.2078160475369
      B(10,3)=0.1781459807619
      B(11,3)=0.1388735102198
      B(12,3)=0.0921214998377
      B(13,3)=0.0404840047653


      B(1,4)= 0.0471753363865
      B(2,4)= 0.1069393259953
      B(3,4)= 0.1600783285433
      B(4,4)= 0.2031674267231
      B(5,4)= 0.2334925365384
      B(6,4)= 0.2491470458134
      B(7,4)= 0.2491470458134
      B(8,4)= 0.2334925365384
      B(9,4)= 0.2031674267231
      B(10,4)=0.1600783285433
      B(11,4)=0.1069393259953
      B(12,4)=0.0471753363865

      B(1,5)= 0.0556685671162
      B(2,5)= 0.1255803694649
      B(3,5)= 0.1862902109277
      B(4,5)= 0.2331937645919
      B(5,5)= 0.2628045445102
      B(6,5)= 0.2729250867779
      B(7,5)= 0.2628045445102
      B(8,5)= 0.2331937645919
      B(9,5)= 0.1862902109277
      B(10,5)=0.1255803694649
      B(11,5)=0.0556685671162


      B(1,6)= 0.0666713443087
      B(2,6)= 0.1494513491506
      B(3,6)= 0.2190863625160
      B(4,6)= 0.2692667193100
      B(5,6)= 0.2955242247148
      B(6,6)= 0.2955242247148
      B(7,6)= 0.2692667193100
      B(8,6)= 0.2190863625160
      B(9,6)= 0.1494513491506
      B(10,6)=0.0666713443087

      B(1,7)= 0.0812743883616
      B(2,7)= 0.1806481606949
      B(3,7)= 0.2606106964029
      B(4,7)= 0.3123470770400
      B(5,7)= 0.3302393550013
      B(6,7)= 0.3123470770400
      B(7,7)= 0.2606106964029
      B(8,7)= 0.1806481606949
      B(9,7)= 0.0812743883616

      B(1,8)= 0.1012285362904
      B(2,8)= 0.2223810344534
      B(3,8)= 0.3137066458779
      B(4,8)= 0.3626837833784
      B(5,8)= 0.3626837833784
      B(6,8)= 0.3137066458779
      B(7,8)= 0.2223810344534
      B(8,8)= 0.1012285362904

      B(1,9)= 0.1294849661689
      B(2,9)= 0.2797053914893
      B(3,9)= 0.3818300505051
      B(4,9)= 0.4179591836735
      B(5,9)= 0.3818300505051
      B(6,9)= 0.2797053914893
      B(7,9)= 0.1294849661689

      B(1,10)= 0.1713244923792
      B(2,10)= 0.3607615730481
      B(3,10)= 0.4679139345727
      B(4,10)= 0.4679139345727
      B(5,10)= 0.3607615730481
      B(6,10)= 0.1713244923792

      B(1,11)= 0.2369268850562
      B(2,11)= 0.4786286704994
      B(3,11)= 0.5688888888889
      B(4,11)= 0.4786286704994
      B(5,11)= 0.2369268850562

      B(1,12)= 0.3478548451375
      B(2,12)= 0.6521451548625
      B(3,12)= 0.6521451548625
      B(4,12)= 0.3478548451375

      B(1,13)= 0.5555555555556
      B(2,13)= 0.8888888888889
      B(3,13)= 0.5555555555556

      B(1,14)= 1.0
      B(2,14)= 1.0

      B(1,15)=2.0
C
C *** ADDITIONAL SOURCE ELEMENT DATA ***
C
      N1=ND1(IS)
      N2=ND2(IS)
      N3=ND3(IS)
      XS=(XND(N1)+XND(N2)+XND(N3))/3.0
      YS=(YND(N1)+YND(N2)+YND(N3))/3.0
C
      A=(S1(IS)+S2(IS)+S3(IS))/3.0
      X=-A*XN(IS)
      Y=-A*YN(IS)
      Z=-A*ZN(IS)
C
      PX=XS+X
      PY=YS+Y
      PZ=ZS+Z
C
C *** INTEGRATION ***
C
      DO 100 I=1,3
      DO 100 J=1,3
        DPA(I,J)=(0.0,0.0)
  100 CONTINUE
C
      DO 200 I=1,3
C
C     * ELEMENT DATA *
C
        IF(I.EQ.1)THEN
          ND2S=N2
          ND3S=N3
        ELSE
          IF(I.EQ.2)THEN
            ND2S=N3
            ND3S=N1
          ELSE
            ND2S=N1
            ND3S=N2
          END IF
        END IF
C
        X1=PX
        Y1=PY
        Z1=PZ
        X2=XND(ND2S)
        Y2=YND(ND2S)
        Z2=ZND(ND2S)
        X3=XND(ND3S)
        Y3=YND(ND3S)
        Z3=ZND(ND3S)
C       
        S1S=SQRT((X2-X3)*(X2-X3)+(Y2-Y3)*(Y2-Y3)+(Z2-Z3)*(Z2-Z3))
        S2S=SQRT((X3-X1)*(X3-X1)+(Y3-Y1)*(Y3-Y1)+(Z3-Z1)*(Z3-Z1))
        S3S=SQRT((X1-X2)*(X1-X2)+(Y1-Y2)*(Y1-Y2)+(Z1-Z2)*(Z1-Z2))
        ANGS=ACOS((S2S*S2S+S3S*S3S-S1S*S1S)/(2.0*S2S*S3S))
C
        A1=X2-X1
        A2=Y2-Y1
        A3=Z2-Z1
        B1=X3-X1
        B2=Y3-Y1
        B3=Z3-Z1
        X=A2*B3-A3*B2
        Y=A3*B1-A1*B3
        Z=A1*B2-A2*B1
        A=SQRT(X*X+Y*Y+Z*Z)
        XNS=X/A
        YNS=Y/A
        ZNS=Z/A
C
        IF(IBS.EQ.2)THEN
          XNS=-XNS
          YNS=-YNS
          ZNS=-ZNS
        END IF
C
        SA=0.25*S2S*S3S*SIN(ANGS)
        DEP2=2.0*(ZS+Z1+Z2+Z3)
        DEP1=-DEP2
C
        DO 210 J=1,NG
          C=0.5*(R(J,1)+1.0)
          A=(1.0-C)*B(J,1)*SA
          DO 210 K=1,NG+1-J
            E=0.5*(1.0-C)*(R(K,J)+1.0)
            AA=A*B(K,J)
            CALL DIRECTP(E,C,AA,XNS,YNS,ZNS,DPA)
  210  CONTINUE
C
  200 CONTINUE
C
      DCS(1,1)=-DPA(1,1)
      DCS(2,1)=-DPA(2,1)
      DCS(3,1)=-DPA(3,1)
      DCS(1,2)=-DPA(1,2)
      DCS(2,2)=-DPA(2,2)
      DCS(3,2)=-DPA(3,2)
      DCS(1,3)=-DPA(1,3)
      DCS(2,3)=-DPA(2,3)
      DCS(3,3)=-DPA(3,3)
C
C *** CHECK OUTPUT (NCK(4).EQ.1) ***
C
 10   IF(NCK(4).EQ.1)THEN
      WRITE(1,*)
      WRITE(1,*)'FROM DCSUP (NCK(4)=1): IS,DCS',IS
      WRITE(1,1000)DCS(1,1),DCS(1,2),DCS(1,3)
      WRITE(1,1000)DCS(2,1),DCS(2,2),DCS(2,3)
      WRITE(1,1000)DCS(3,1),DCS(3,2),DCS(3,3)
 1000 FORMAT(6E12.4)
      WRITE(1,*)'PX,PY,PZ',PX,PY,PZ
      END IF
C
      RETURN
      END
C
C *** DIRECT TRACTION GREEN FUNCTION ***
C
      SUBROUTINE DIRECTP(E,C,AA,XNS,YNS,ZNS,DP)
C
      COMPLEX PP(3,3),DP(3,3),VP,VS
      COMMON /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /DPSO /DEP1,DEP2,ZS,ZO /SOLY/LS,SDEP,LO,ODEP
     *    /CPASY/XS,YS,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3
C
C *** CHECK OF DIMENSION ***
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM PASYM:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
      H1=1.0-E-C
      H2=E
      H3=C
      XO=H1*X1+H2*X2+H3*X3
      YO=H1*Y1+H2*Y2+H3*Y3
      ZO=H1*Z1+H2*Z2+H3*Z3
C
      LO=LS
C
      RX=XO-XS
      RY=YO-YS
      CALL DASYMT(PP,RX,RY,XNS,YNS,ZNS)
C
      DO 200 I=1,3
      DO 200 J=1,3
        DP(I,J)=DP(I,J)+PP(J,I)*AA
  200 CONTINUE
C
      RETURN
      END
C
C *** THE INCIDENT WAVE VECTOR TO SP FROM DISLOCATION FAULTS ***
C
      SUBROUTINE FLU(OM,MT,IS,UF)
C
      COMPLEX UF(MT),VP,VS,SM,RAM,SMO,EDT,GX,GY,GZ,A,B
     *      ,QX1(0:2),QZ1(0:2),VX1(0:2),WX1(0:2),WZ1(0:2)
     *      ,QX2(0:2),QZ2(0:2),VX2(0:2),WX2(0:2),WZ2(0:2)
     *      ,QXS(0:2),QZS(0:2),VXS(0:2),WXS(0:2),WZS(0:2)
     *      ,QX(0:3),QY(0:3),QZ(0:3),VX(0:3),VY(0:3)
     *      ,WX(0:3),WY(0:3),WZ(0:3),UX(3,3),UY(3,3),UZ(3,3)
      DIMENSION EN(3,3)
      COMMON /NODE/NND,XND(200),YND(200),ZND(200) 
     *  /NELM/NEL,ND1(200),ND2(200),ND3(200)
     *  /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *  /INTG/C11,N11,C12,N12 /INTG2/I12,WNB2,N21,WNC2,N22
     *  /FLT/NF,XF(30),YF(30),LF(30),DEP(30),STR(30),DIP(30),RAK(30)
     *      ,FL(30),FW(30),FD(30),RT(30),VR(30),NVR(30),TD(30)
     *  /DPSO /DEP1,DEP2,ZS,ZO  /SOLY/LS,SDEP,LFL,FDEP 
     *  /IASYM/IST  /FCQVW/SM,RAM,RR  /CHECK/NCK(10)
C
C *** CHECK OF DIMENSION ***
C
      NC=200
      IF(NND.GE.NC)THEN
        WRITE(1,*)' FROM FLU:NND>NC !!!!!!!!!!'
        WRITE(1,*)' NND,NC=',NND,NC
        STOP
      END IF
C
      NC=200
      IF(NEL.GE.NC)THEN
        WRITE(1,*)' FROM FLU:NEL>NC !!!!!!!!!!'
        WRITE(1,*)' NND,NC=',NEL,NC
        STOP
      END IF
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM FLU:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
      NC=30
      IF(NF.GE.NC)THEN
        WRITE(1,*)' FROM FLU:NF>NC !!!!!!!!!!'
        WRITE(1,*)' NF,NC=',NF,NC
        STOP
      END IF
C
C *** INCIDENT WAVES ***
C
        IF(I12.EQ.1)THEN
          N1=N11
          N2=N12
          WNB=OM/C12
          WNA=WNB/(1000.0*N1)
          WNC=OM/C11
        ELSE
          N1=N21
          N2=N22
          WNB=WNB2
          WNA=WNB/(1000.0*N1)
          WNC=WNC2
        END IF
C
        GX=(0.0,0.0)
        GY=(0.0,0.0)
        GZ=(0.0,0.0)
C
        XS=(XND(ND1(IS))+XND(ND2(IS))+XND(ND3(IS)))/3.0
        YS=(YND(ND1(IS))+YND(ND2(IS))+YND(ND3(IS)))/3.0
C
        DO 150 IO=1,NF
C
          RX=XF(IO)-XS
          RY=YF(IO)-YS
          RR=SQRT(RX*RX+RY*RY)
C
          LFL=LF(IO)
          ZO=DEP(IO)
          FDEP=ZO
          DO 160 L=2,LF(IO)
            FDEP=FDEP-THK(L-1)
  160     CONTINUE
C
          CALL ENMO(IO,OM,EN,SMO)
          EDT=CEXP(CMPLX(0.0,OM*TD(IO)))
          SMO=SMO*EDT
C
          IF((IST.EQ.1).AND.(IABS(LFL-LS).LE.1))THEN
            CALL CASYM(LS,NL)
          END IF
C
          CALL QVWRZ(OM,WNA,WNB,N1,QX1,QZ1,VX1,WX1,WZ1,1)
          CALL QVWRZ(OM,WNB,WNC,N2,QX2,QZ2,VX2,WX2,WZ2,2)
C
          DO 170 J=0,2
            QXS(J)=(0.0,0.0)
            VXS(J)=(0.0,0.0)
            WXS(J)=(0.0,0.0)
            QZS(J)=(0.0,0.0)
            WZS(J)=(0.0,0.0)
  170     CONTINUE   
C
          IF((IST.EQ.1).AND.(IABS(LFL-LS).LE.1))THEN
            CALL AINTG(RR,LS,NL,QXS,QZS,VXS,WXS,WZS)
          END IF
C
          IF(RR.EQ.0.0)THEN
          CR=0.0
          SR=0.0
          C2=0.0
          S2=0.0
          CS=0.0
          CX=0.0
          SY=0.0
          CY=0.0
          ELSE
          CR=RX/RR
          SR=RY/RR
          C2=CR*CR
          S2=SR*SR
          CS=CR*SR
          CX=S2/RR
          SY=C2/RR
          CY=-CS/RR
          END IF
          SX=CY
C
          A=QX1(0)+QX2(0)+QXS(0)
          QX(0)=A*CR
          QY(0)=A*SR
          B=QX1(1)+QX2(1)+QXS(1)
          QX(1)=B*C2+A*CX
          QY(1)=B*CS+A*SX
          QX(2)=B*CS+A*CY
          QY(2)=B*S2+A*SY
          B=QX1(2)+QX2(2)+QXS(2)
          QX(3)= B*CR
          QY(3)= B*SR
C
          QZ(0)=-(QZ1(0)+QZ2(0)+QZS(0))
          B=QZ1(1)+QZ2(1)+QZS(1)
          QZ(1)=-B*CR
          QZ(2)=-B*SR
          QZ(3)=-(QZ1(2)+QZ2(2)+QZS(2))
C
          A=VX1(0)+VX2(0)+VXS(0)
          VX(0)=-A*SR
          VY(0)= A*CR
          B=VX1(1)+VX2(1)+VXS(1)
          VX(1)=-(B*CS+A*SX)
          VY(1)=  B*C2+A*CX
          VX(2)=-(B*S2+A*SY)
          VY(2)=  B*CS+A*CY
          B=VX1(2)+VX2(2)+VXS(2)
          VX(3)=-B*SR
          VY(3)= B*CR
C
          A=WX1(0)+WX2(0)+WXS(0)
          WX(0)=-A*CR
          WY(0)=-A*SR
          B=WX1(1)+WX2(1)+WXS(1)
          WX(1)=-(B*C2+A*CX)
          WY(1)=-(B*CS+A*SX)
          WX(2)=-(B*CS+A*CY)
          WY(2)=-(B*S2+A*SY)
          B=WX1(2)+WX2(2)+WXS(2)
          WX(3)=-B*CR
          WY(3)=-B*SR
C
          WZ(0)=-(WZ1(0)+WZ2(0)+WZS(0))
          B=WZ1(1)+WZ2(1)+WZS(1)
          WZ(1)=-B*CR
          WZ(2)=-B*SR
          WZ(3)=-(WZ1(2)+WZ2(2)+WZS(2))
C
          UX(1,1)=QX(1)*CR+QX(0)*CX-VX(1)*SR-VX(0)*SX
          UX(1,2)=QX(2)*CR+QX(0)*CY-VX(2)*SR-VX(0)*SY
          UY(1,1)=QY(1)*CR+QY(0)*CX-VY(1)*SR-VY(0)*SX
          UY(1,2)=QY(2)*CR+QY(0)*CY-VY(2)*SR-VY(0)*SY
          UZ(1,1)=QZ(1)*CR+QZ(0)*CX
          UZ(1,2)=QZ(2)*CR+QZ(0)*CY
C
          UX(2,1)=QX(1)*SR+QX(0)*SX+VX(1)*CR+VX(0)*CX
          UX(2,2)=QX(2)*SR+QX(0)*SY+VX(2)*CR+VX(0)*CY
          UY(2,1)=QY(1)*SR+QY(0)*SX+VY(1)*CR+VY(0)*CX
          UY(2,2)=QY(2)*SR+QY(0)*SY+VY(2)*CR+VY(0)*CY
          UZ(2,1)=QZ(1)*SR+QZ(0)*SX
          UZ(2,2)=QZ(2)*SR+QZ(0)*SY
C
          UX(3,1)=WX(1)
          UX(3,2)=WX(2)
          UY(3,1)=WY(1)
          UY(3,2)=WY(2)
          UZ(3,1)=WZ(1)
          UZ(3,2)=WZ(2)
C
          UX(1,3)=QX(3)*CR-VX(3)*SR
          UY(1,3)=QY(3)*CR-VY(3)*SR
          UZ(1,3)=QZ(3)*CR
          UX(2,3)=QX(3)*SR+VX(3)*CR
          UY(2,3)=QY(3)*SR+VY(3)*CR
          UZ(2,3)=QZ(3)*SR
          UX(3,3)=WX(3)
          UY(3,3)=WY(3)
          UZ(3,3)=WZ(3)
C
          DO 180 I=1,3
          DO 180 J=1,3
            GX=GX+EN(I,J)*UX(J,I)*SMO
            GY=GY+EN(I,J)*UY(J,I)*SMO
            GZ=GZ+EN(I,J)*UZ(J,I)*SMO
  180     CONTINUE
C
  150   CONTINUE
C
        UF(3*(IS-1)+1)=GX
        UF(3*(IS-1)+2)=GY
        UF(3*(IS-1)+3)=GZ
C
      RETURN
      END
C
C
C *** EN AND SMO ***
C
      SUBROUTINE ENMO(IS,OM,EN,SMO)
C
      DIMENSION EN(3,3)
      COMPLEX VS,VP,SMO,CPX,SM,RAM,STT,STL
      COMMON/STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /FLT/NF,XF(30),YF(30),LF(30),DEP(30),STR(30),DIP(30),RAK(30)
     *        ,FL(30),FW(30),FD(30),RT(30),VR(30),NVR(30),TD(30)
     *    /FCQVW/SM,RAM,RR
C
C *** CHECK OF DIMENSION ***
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM ENMO:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
      NC=30
      IF(NF.GE.NC)THEN
        WRITE(1,*)' FROM ENMO:NF>NC !!!!!!!!!!'
        WRITE(1,*)' NF,NC=',NF,NC
        STOP
      END IF
C
      CPX=(0.0,1.0)
C
C *** EN ***
C
      CST= COS(STR(IS))
      SST= SIN(STR(IS))
C
      CDP= COS(DIP(IS))
      SDP= SIN(DIP(IS))
C
      CRK= COS(RAK(IS))
      SRK= SIN(RAK(IS))
C
      XN=-SDP*SST
      YN= SDP*CST
      ZN=-CDP
C
      EX= CRK*CST+SRK*CDP*SST
      EY= CRK*SST-SRK*CDP*CST
      EZ=-SRK*SDP
C
      EN(1,1)= 2.0*EX*XN
      EN(1,2)= EX*YN +EY*XN
      EN(1,3)= EX*ZN +EZ*XN
      EN(2,1)= EY*XN +EX*YN
      EN(2,2)= 2.0*EY*YN
      EN(2,3)= EY*ZN +EZ*YN
      EN(3,1)= EZ*XN +EX*ZN
      EN(3,2)= EZ*YN +EY*ZN
      EN(3,3)= 2.0*EZ*ZN
C
C *** SMO ***
C
      L=LF(IS)
      SM = DNS(L)*VS(L)*VS(L)
      RAM= DNS(L)*VP(L)*VP(L)-2.0*SM
C
      SMO= FD(IS)*SM*FL(IS)*FW(IS)
C
      IF(NVR(IS).EQ.1)THEN
        STL= (1.0,0.0)
      ELSE
        TL=FL(IS)/VR(IS)
        TTL= OM*TL/2.0
        STL= SIN(TTL)*CEXP(CPX*TTL)/TTL
      END IF
C
      TTK= OM*RT(IS)/2.0
      IF(TTK.EQ.0.0)THEN
        STT= (1.0,0.0)
      ELSE
        STT= SIN(TTK)*CEXP(CPX*TTK)/TTK
      END IF
C
      SMO=CPX*SMO*STL*STT/OM
C
      RETURN
      END
C
C *** THE 3*3 INTEGRATION MATRIX OF THE DISPLACEMENT AND TRACTION GREEN 
C     FUNCTIONS FOR THE CASE THAT THE SOURCE NODE IS NOT ON THE ELEMENT ***
C
      SUBROUTINE DUPN(OM,IS,IE,XN,YN,ZN,S2,S3,ANG,EU,EP)
C
      COMPLEX EU(3,3),EP(3,3),VS,VP
      COMMON /NODE/NND,XND(200),YND(200),ZND(200)
     *    /NELM/NEL,ND1(200),ND2(200),ND3(200)
     *    /DPSO /DEP1,DEP2,ZS,ZO /SOLY/LS,SDEP,LO,ODEP
     *    /CUPN/XS,YS,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3
     *    /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /CHECK/NCK(10)
      DATA A1,A2,A3,A4,A5/0.3333333333,0.7974269853
     *      ,0.1012865073,0.0597158717,0.4701420641/
     *     W1,W2,W3/0.255,0.1259391805,0.1323941527/
C
C *** CHECK OF DIMENSION ***
C
      NC=200
      IF(NND.GE.NC)THEN
        WRITE(1,*)' FROM DUPN:NND>NC !!!!!!!!!!'
        WRITE(1,*)' NND,NC=',NND,NC
        STOP
      END IF
C
      NC=200
      IF(NEL.GE.NC)THEN
        WRITE(1,*)' FROM DUPN:NEL>NC !!!!!!!!!!'
        WRITE(1,*)' NEL,NC=',NEL,NC
        STOP
      END IF
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM DUPN:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
C *** SOURCE ***
C
      N1=ND1(IS)
      N2=ND2(IS)
      N3=ND3(IS)
      XS=(XND(N1)+XND(N2)+XND(N3))/3.0
      YS=(YND(N1)+YND(N2)+YND(N3))/3.0
C
C *** INTEGRATION OVER THE ELEMENT ***
C
      X1=XND(ND1(IE))
      Y1=YND(ND1(IE))
      Z1=ZND(ND1(IE))
      X2=XND(ND2(IE))
      Y2=YND(ND2(IE))
      Z2=ZND(ND2(IE))
      X3=XND(ND3(IE))
      Y3=YND(ND3(IE))
      Z3=ZND(ND3(IE))
      SA=0.5*S2*S3*SIN(ANG)
C
      ZC=(Z1+Z2+Z3)/3.0
      DRU=0.0
      DRL=THK(1)
      DO 100 L=1,NL
        IF((ZC.GE.DRU).AND.(ZC.LT.DRL))LO=L
        IF((ZC.GE.DRU).AND.(L.EQ.NL))LO=L
        DRU=DRL
        DRL=DRL+THK(L+1)
  100 CONTINUE
C
      DO 120 J=1,3
      DO 120 I=1,3
        EU(I,J)=(0.0,0.0)
        EP(I,J)=(0.0,0.0)
  120 CONTINUE
C
C   * 1 POINT *
C
      AA=W1*SA
      CALL UPN(OM,A1,A1,AA,XN,YN,ZN,EU,EP)
C
C   * 2-1 POINT *
C
      AA=W2*SA
      CALL UPN(OM,A2,A3,AA,XN,YN,ZN,EU,EP)
C
C   * 2-2 POINT *
C
      CALL UPN(OM,A3,A2,AA,XN,YN,ZN,EU,EP)
C
C   * 2-3 POINT *
C
      CALL UPN(OM,A3,A3,AA,XN,YN,ZN,EU,EP)
C
C   * 3-1 POINT *
C
      AA=W3*SA
      CALL UPN(OM,A4,A5,AA,XN,YN,ZN,EU,EP)
C
C   * 3-2 POINT *
C
      CALL UPN(OM,A5,A4,AA,XN,YN,ZN,EU,EP)
C
C   * 3-3 POINT *
C
      CALL UPN(OM,A5,A5,AA,XN,YN,ZN,EU,EP)
C
C *** CHECK OUTPUT ***
C
      IF(NCK(6).EQ.1)THEN
        WRITE(1,*)
        WRITE(1,*)'FROM DUPN (NCK(6)=1): IS,IE,EU',IS,IE
        WRITE(1,1000)EU(1,1),EU(1,2),EU(1,3)
        WRITE(1,1000)EU(2,1),EU(2,2),EU(2,3)
        WRITE(1,1000)EU(3,1),EU(3,2),EU(3,3)
        WRITE(1,*)
        WRITE(1,*)'FROM DUPN (NCK(6)=1): IS,IE,EP',IS,IE
        WRITE(1,1000)EP(1,1),EP(1,2),EP(1,3)
        WRITE(1,1000)EP(2,1),EP(2,2),EP(2,3)
        WRITE(1,1000)EP(3,1),EP(3,2),EP(3,3)
      END IF
 1000 FORMAT(6E12.4)
C
      RETURN
      END
C
C
C *** GREEN FUNCTION ***
C
      SUBROUTINE UPN(OM,E,C,AA,XN,YN,ZN,EU,EP)
C
      COMPLEX EU(3,3),EP(3,3),UU(3,3),PP(3,3),VP,VS
      COMMON /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /DPSO /DEP1,DEP2,ZS,ZO /SOLY/LS,SDEP,LO,ODEP
     *    /CUPN/XS,YS,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3
C
C *** CHECK OF DIMENSION ***
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM UPN:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
      H1=1.0-E-C
      H2=E
      H3=C
      XO=H1*X1+H2*X2+H3*X3
      YO=H1*Y1+H2*Y2+H3*Y3
      ZO=H1*Z1+H2*Z2+H3*Z3
C
      ODEP=ZO
      DO 110 L=2,LO
        ODEP=ODEP-THK(L-1)
  110 CONTINUE
C
      RX=XO-XS
      RY=YO-YS
      CALL GRNN(OM,UU,PP,RX,RY,XN,YN,ZN)
C
      DO 200 I=1,3
      DO 200 J=1,3
        EU(I,J)=EU(I,J)+UU(J,I)*AA
        EP(I,J)=EP(I,J)+PP(J,I)*AA
  200 CONTINUE
C
      RETURN
      END
C
C *** THE 3*3 INTEGRATION MATRIX OF THE DISPLACEMENT AND TRACTION GREEN 
C     FUNCTIONS FOR THE CASE THAT THE SOURCE NODE IS ON THE ELEMENT ***
C
      SUBROUTINE DUPE(OM,IS,IE,XN,YN,ZN,S1,S2,S3,EU,EP)
C
      REAL L1,L2,L3,L4
      COMPLEX EU(3,3),EP(3,3),VP,VS
      COMMON /NODE/NND,XND(200),YND(200),ZND(200)
     *  /NELM/NEL,ND1(200),ND2(200),ND3(200)
     *  /DPSO /DEP1,DEP2,ZS,ZO /SOLY/LS,SDEP,LO,ODEP
     *  /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *  /CUPE/XS,YS,XX2,YY2,ZZ2,XX3,YY3,ZZ3,BL,CL,DA,SDA
     *  /CHECK/NCK(10)
c      DATA A1,A2,A3,A4,A5/ 0.2369268850, 0.4786286704
c     *     , 0.5688888889, 0.4786286704, 0.2369268850/
c     *     R1,R2,R3,R4,R5/-0.9061798459,-0.5384693101
c     *     , 0.0000000000, 0.5384693101, 0.9061798459/
      DATA A1,A2,A3,A4/ 0.3478548451, 0.6521451548
     *                , 0.6521451548, 0.3478548451/
     *     R3,R4/ 0.3399810435, 0.8611363115/
      R1=-0.8611363115
      R2=-0.3399810435
C
C *** CHECK OF DIMENSION ***
C
      NC=200
      IF(NND.GE.NC)THEN
        WRITE(1,*)' FROM DUPE:NND>NC !!!!!!!!!!'
        WRITE(1,*)' NND,NC=',NND,NC
        STOP
      END IF
C
      NC=200
      IF(NEL.GE.NC)THEN
        WRITE(1,*)' FROM DUPE:NEL>NC !!!!!!!!!!'
        WRITE(1,*)' NEL,NC=',NEL,NC
        STOP
      END IF
C
C *** SOURCE ***
C
      N1=ND1(IS)
      N2=ND2(IS)
      N3=ND3(IS)
      XS=(XND(N1)+XND(N2)+XND(N3))/3.0
      YS=(YND(N1)+YND(N2)+YND(N3))/3.0
C
C *** INTEGRATION OVER THE ELEMENT ***
C
      N1=ND1(IE)
      N2=ND2(IE)
      N3=ND3(IE)
C
      X1=XND(N1)
      Y1=YND(N1)
      Z1=ZND(N1)
      X2=XND(N2)
      Y2=YND(N2)
      Z2=ZND(N2)
      X3=XND(N3)
      Y3=YND(N3)
      Z3=ZND(N3)
C
      ZC=(Z1+Z2+Z3)/3.0
      DRU=0.0
      DRL=THK(1)
      DO 100 L=1,NL
        IF((ZC.GE.DRU).AND.(ZC.LT.DRL))LO=L
        IF((ZC.GE.DRU).AND.(L.EQ.NL))LO=L
        DRU=DRL
        DRL=DRL+THK(L+1)
  100 CONTINUE
C
      X=XS-X1
      Y=YS-Y1
      Z=ZS-Z1
      AN=SQRT(X*X+Y*Y+Z*Z)
      X=XS-X2
      Y=YS-Y2
      Z=ZS-Z2
      BN=SQRT(X*X+Y*Y+Z*Z)
      X=XS-X3
      Y=YS-Y3
      Z=ZS-Z3
      CN=SQRT(X*X+Y*Y+Z*Z)
C
      DO 120 J=1,3
      DO 120 K=1,3
        EU(K,J)=(0.0,0.0)
        EP(K,J)=(0.0,0.0)
  120 CONTINUE
C
      DO 200 I=1,3
C
      IF(I.EQ.1)THEN
        XX2=X2
        YY2=Y2
        ZZ2=Z2
        XX3=X3
        YY3=Y3
        ZZ3=Z3
        AL=S1
        BL=CN
        CL=BN
      ELSE
        IF(I.EQ.2)THEN
          XX2=X3
          YY2=Y3
          ZZ2=Z3
          XX3=X1
          YY3=Y1
          ZZ3=Z1
          AL=S2
          BL=AN
          CL=CN
        ELSE
          XX2=X1
          YY2=Y1
          ZZ2=Z1
          XX3=X2
          YY3=Y2
          ZZ3=Z2
          AL=S3
          BL=BN
          CL=AN
        END IF
      END IF
      DA=ACOS((BL*BL+CL*CL-AL*AL)/(2.0*BL*CL))
      SDA=SIN(DA)
C
C   * 1-1 POINT *
C
      T1 =0.5*(1.0+R1)*DA
      L1 =BL*CL*SDA/(CL*SIN(T1)+BL*SIN(DA-T1))
      A=DA*0.125*A1*L1*L1
      AA=A*A1*(1+R1)
      CALL UPE(OM,T1,L1,R1,AA,XN,YN,ZN,EU,EP)
C
C   * 1-2 POINT *
C
      AA=A*A2*(1+R2)
      CALL UPE(OM,T1,L1,R2,AA,XN,YN,ZN,EU,EP)
C
C   * 1-3 POINT *
C
      AA=A*A3*(1+R3)
      CALL UPE(OM,T1,L1,R3,AA,XN,YN,ZN,EU,EP)
C
C   * 1-4 POINT *
C
      AA=A*A4*(1+R4)
      CALL UPE(OM,T1,L1,R4,AA,XN,YN,ZN,EU,EP)
C
C   * 2-1 POINT *
C
      T2 =0.5*(1.0+R2)*DA
      L2 =BL*CL*SDA/(CL*SIN(T2)+BL*SIN(DA-T2))
      A=DA*0.125*A2*L2*L2
      AA=A*A1*(1+R1)
      CALL UPE(OM,T2,L2,R1,AA,XN,YN,ZN,EU,EP)
C
C   * 2-2 POINT *
C
      AA=A*A2*(1+R2)
      CALL UPE(OM,T2,L2,R2,AA,XN,YN,ZN,EU,EP)
C
C   * 2-3 POINT *
C
      AA=A*A3*(1+R3)
      CALL UPE(OM,T2,L2,R3,AA,XN,YN,ZN,EU,EP)
C
C   * 2-4 POINT *
C
      AA=A*A4*(1+R4)
      CALL UPE(OM,T2,L2,R4,AA,XN,YN,ZN,EU,EP)
C
C   * 3-1 POINT *
C
      T3 =0.5*(1.0+R3)*DA
      L3 =BL*CL*SDA/(CL*SIN(T3)+BL*SIN(DA-T3))
      A=DA*0.125*A3*L3*L3
      AA=A*A1*(1+R1)
      CALL UPE(OM,T3,L3,R1,AA,XN,YN,ZN,EU,EP)
C
C   * 3-2 POINT *
C
      AA=A*A2*(1+R2)
      CALL UPE(OM,T3,L3,R2,AA,XN,YN,ZN,EU,EP)
C
C   * 3-3 POINT *
C
      AA=A*A3*(1+R3)
      CALL UPE(OM,T3,L3,R3,AA,XN,YN,ZN,EU,EP)
C
C   * 3-4 POINT *
C
      AA=A*A4*(1+R4)
      CALL UPE(OM,T3,L3,R4,AA,XN,YN,ZN,EU,EP)
C
C   * 4-1 POINT *
C
      T4 =0.5*(1.0+R4)*DA
      L4 =BL*CL*SDA/(CL*SIN(T4)+BL*SIN(DA-T4))
      A=DA*0.125*A4*L4*L4
      AA=A*A1*(1+R1)
      CALL UPE(OM,T4,L4,R1,AA,XN,YN,ZN,EU,EP)
C
C   * 4-2 POINT *
C
      AA=A*A2*(1+R2)
      CALL UPE(OM,T4,L4,R2,AA,XN,YN,ZN,EU,EP)
C
C   * 4-3 POINT *
C
      AA=A*A3*(1+R3)
      CALL UPE(OM,T4,L4,R3,AA,XN,YN,ZN,EU,EP)
C
C   * 4-4 POINT *
C
      AA=A*A4*(1+R4)
      CALL UPE(OM,T4,L4,R4,AA,XN,YN,ZN,EU,EP)
C
  200 CONTINUE
C
C *** CHECK OUTPUT ***
C
      IF(NCK(5).EQ.1)THEN
        WRITE(1,*)
        WRITE(1,*)'FROM DUPE (NCK(5)=1): IS,IE,EU',IS,IE
        WRITE(1,1000)EU(1,1),EU(1,2),EU(1,3)
        WRITE(1,1000)EU(2,1),EU(2,2),EU(2,3)
        WRITE(1,1000)EU(3,1),EU(3,2),EU(3,3)
        WRITE(1,*)
        WRITE(1,*)'FROM DUPE (NCK(5)=1): IS,IE,EP',IS,IE
        WRITE(1,1000)EP(1,1),EP(1,2),EP(1,3)
        WRITE(1,1000)EP(2,1),EP(2,2),EP(2,3)
        WRITE(1,1000)EP(3,1),EP(3,2),EP(3,3)
      END IF
 1000 FORMAT(6E12.4)
C
      RETURN
      END
C
C *** GREEN FUNCTIONS ***
C
      SUBROUTINE UPE(OM,T,LT,RS,AA,XN,YN,ZN,EU,EP)
C     
      REAL LT,LL
      COMPLEX EU(3,3),EP(3,3),UU(3,3),PA(3,3),PP(3,3),VP,VS
      COMMON /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /DPSO /DEP1,DEP2,ZS,ZO /SOLY/LS,SDEP,LO,ODEP
     *    /CUPE/XS,YS,X2,Y2,Z2,X3,Y3,Z3,BL,CL,DA,SDA
C
C *** CHECK OF DIMENSION ***
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM UPE:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
C *** GREEN FUNCTION ***
C
      LL=0.5*(1.0+RS)*LT
      C=LL*SIN(T)/(BL*SDA)
      E=LL*SIN(DA-T)/(CL*SDA)
C
      H1=1.0-E-C
      H2=E
      H3=C
      XO=H1*XS+H2*X2+H3*X3
      YO=H1*YS+H2*Y2+H3*Y3
      ZO=H1*ZS+H2*Z2+H3*Z3
C
      ODEP=ZO
      DO 110 L=2,LO
        ODEP=ODEP-THK(L-1)
  110 CONTINUE
C
      RX=XO-XS
      RY=YO-YS
      CALL GRNN(OM,UU,PP,RX,RY,XN,YN,ZN)
C
      CALL DASYMT(PA,RX,RY,XN,YN,ZN)
C
      DO 200 I=1,3
      DO 200 J=1,3
        EU(I,J)=EU(I,J)+AA*UU(J,I)
        EP(I,J)=EP(I,J)+AA*(PP(J,I)-PA(J,I))
  200 CONTINUE
C
      RETURN
      END
C
C
C *** SH UPGOING/DOWNGOING COEFFICIENTS USING R/T MATRIX ***
C
      SUBROUTINE CUDSH(OM,WNA,WNB,NWN,M)
C
      COMPLEX VP,VS,CD,CU,VS2,WS2,CMS,SM,EE(2,2),DD,DU
     *      ,CUSU,CDSU,CDSD,CUSD,GTD,GTU,GRD,GRU,AU,BU,AD,BD,CS
      COMMON /SOLY/LS,SDEP,LO,ODEP
     *    /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
      COMMON /DUSH/CD(510,20,2),CU(510,20,2)
     *       ,CUSU(510,2),CDSU(510,2),CDSD(510,2),CUSD(510,2) 
     *    /GRTSH/GTD(0:20),GTU(0:20),GRD(0:20),GRU(0:20)
C
C *** CHECK FOR THE DIMENSION OF CD, CU, AND GTD-GRU ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM CUDSH: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
      NC=510
      NN=2*NWN+1
      IF(NN.GT.NC)THEN
         WRITE(1,*)' FROM CUDSH: NMN*2+1.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** DOWN/UP-R/T COEFFICIENTS FOR ALL LAYERS AT ALL WAVE-NUMBERS ***
C
      OM2=OM*OM
      VS2=VS(LS)*VS(LS)
      WS2=OM2/VS2
      SM=DNS(LS)*VS2
      EE(1,1)=(1.0,0.0)
      EE(1,2)=(1.0,0.0)
C
      DWN=0.5*(WNB-WNA)/FLOAT(NWN)
      DO 100 I=1,2*NWN+1
C
        WN=WNA+DWN*FLOAT(I-1)
C
C     * COMPUTATION OF GENERALIZED R/T MATRICES *
C
        CALL GNRTSH(OM,WN)
C
C     * COMPUTATION OF  CD AND CU *
C
        WN2=WN*WN
        CMS=CSQRT(WN2-WS2)
        IF(REAL(CMS).LT.0.0)CMS=-CMS
C
        EE(2,1)=-SM*CMS
        EE(2,2)= SM*CMS
C
        DQ=-WN/(2.0*3.1415926536)
C
        IF((LS.EQ.1).AND.(SDEP.EQ.0.0))THEN
C
          IF(NL.EQ.1)THEN
            CDSD(I,M)=DQ/EE(2,1)
            CUSD(I,M)=(0.0,0.0)
          ELSE
            DD=CEXP(-CMS*THK(1))
            CDSD(I,M)=DQ/(EE(2,1)+EE(2,2)*DD*GRD(1))
            CUSD(I,M)=GRD(1)*CDSD(I,M)
          END IF
C
        ELSE
C 
          IF(LS.EQ.NL)THEN 
C
            DD=CEXP(-CMS*SDEP)
C
            AU=EE(1,1)*DD*GRU(LS-1)+EE(1,2)
            BU=EE(2,1)*DD*GRU(LS-1)+EE(2,2)
            AD=EE(1,1)
            BD=EE(2,1)
            CS=AU/AD
C
            CUSU(I,M)=DQ/(BD*CS-BU)
            CDSU(I,M)=GRU(LS-1)*CUSU(I,M)
            CDSD(I,M)=CS*CUSU(I,M)
C
          ELSE
C
            DD=CEXP(-CMS*SDEP)
            DU=CEXP(-CMS*(THK(LS)-SDEP))
C
            AU=EE(1,1)*DD*GRU(LS-1)+EE(1,2)
            BU=EE(2,1)*DD*GRU(LS-1)+EE(2,2)
            AD=EE(1,1)+EE(1,2)*DU*GRD(LS)
            BD=EE(2,1)+EE(2,2)*DU*GRD(LS)
            CS=AU/AD
C
            CUSU(I,M)=DQ/(BD*CS-BU)
            CDSU(I,M)=GRU(LS-1)*CUSU(I,M)
            CDSD(I,M)=CS*CUSU(I,M)
            CUSD(I,M)=GRD(LS)*CDSD(I,M)
C
          ENDIF
C
        END IF
C
        IF(LS.EQ.1)GOTO 10
        CU(I,LS-1,M)=GTU(LS-1)*CUSU(I,M)
        DO 110 J=LS-2,1,-1
          CU(I,J,M)=GTU(J)*CU(I,J+1,M)
          CD(I,J+1,M)=GRU(J)*CU(I,J+1,M)
  110   CONTINUE
        CD(I,1,M)=GRU(0)*CU(I,1,M)
C
   10   IF(LS.EQ.NL)GOTO 100
        CD(I,LS+1,M)=GTD(LS)*CDSD(I,M)
        DO 120 J=LS+1,NL-1
          CD(I,J+1,M)=GTD(J)*CD(I,J,M)
          CU(I,J,M)=GRD(J)*CD(I,J,M)
  120   CONTINUE
C
  100 CONTINUE
C
      RETURN
      END
C
C
C *** P-SV UPGOING/DOWNGOING COEFFICIENTS USING R/T MATRIX ***
C
      SUBROUTINE CUDPSV(OM,WNA,WNB,NWN,M)
C
      COMPLEX VP,VS,CMP,CMS,EE(4,4),DD(2,2),DU(2,2)
     *    ,CDX,CUX,CUSUX,CDSUX,CDSDX,CUSDX,GTD,GTU,GRD,GRU,DT
     *    ,CDZ,CUZ,CUSUZ,CDSUZ,CDSDZ,CUSDZ
     *    ,AU(2,2),BU(2,2),AD(2,2),BD(2,2),CS(2,2),E1(2,2),E2(2,2)
      COMMON /SOLY/LS,SDEP,LO,ODEP 
     *  /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *  /DUPSVX/CDX(510,2,20,2),CUX(510,2,20,2),CUSUX(510,2,2)
     *         ,CDSUX(510,2,2),CDSDX(510,2,2),CUSDX(510,2,2) 
     *  /DUPSVZ/CDZ(510,2,20,2),CUZ(510,2,20,2),CUSUZ(510,2,2)
     *         ,CDSUZ(510,2,2),CDSDZ(510,2,2),CUSDZ(510,2,2) 
     *  /GRTPSV/GTD(2,2,0:20),GTU(2,2,0:20),GRD(2,2,0:20),GRU(2,2,0:20)
C
C *** CHECK FOR THE DIMENSION OF CD, CU, AND GTD-GRU ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM CUDPSV: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
      NC=510
      NN=NWN*2+1
      IF(NN.GT.NC)THEN
         WRITE(1,*)' FROM CUDPSV: NWN*2+1.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** COMPUTATION OF GENERALIZED R/T MATRICES ***
C
C
      DWN=0.5*(WNB-WNA)/FLOAT(NWN)
      DO 100 K=1,2*NWN+1
C
        WN=WNA+DWN*FLOAT(K-1)
        CALL GNRTPSV(OM,WN)
C
C *** COMPUTATION OF CD AND CU ***
C
        CALL MTXPSV(OM,WN,LS,CMS,CMP,EE)
C
        DQX=-WN/(2.0*3.1415926536)
        DQZ= WN/(2.0*3.1415926536)
C
        IF((LS.EQ.1).AND.(SDEP.EQ.0.0))THEN
C
          IF(NL.EQ.1)THEN
C
            DT=EE(3,1)*EE(4,2)-EE(3,2)*EE(4,1)
            E2(1,1)= EE(4,2)/DT
            E2(1,2)=-EE(3,2)/DT
            E2(2,1)=-EE(4,1)/DT
            E2(2,2)= EE(3,1)/DT
C
            CDSDX(K,1,M)=E2(1,1)*DQX
            CDSDX(K,2,M)=E2(2,1)*DQX
            CUSDX(K,1,M)=(0.0,0.0)
            CUSDX(K,2,M)=(0.0,0.0)
            CDSDZ(K,1,M)=E2(1,2)*DQZ
            CDSDZ(K,2,M)=E2(2,2)*DQZ
            CUSDZ(K,1,M)=(0.0,0.0)
            CUSDZ(K,2,M)=(0.0,0.0)
C
          ELSE
C
            CALL DDUPSV(OM,WN,THK(1),CMS,CMP,DU)
C
            E2(1,1)=EE(3,3)*DU(1,1)+EE(3,4)*DU(2,1)
            E2(1,2)=EE(3,3)*DU(1,2)+EE(3,4)*DU(2,2)
            E2(2,1)=EE(4,3)*DU(1,1)+EE(4,4)*DU(2,1)
            E2(2,2)=EE(4,3)*DU(1,2)+EE(4,4)*DU(2,2)
            E1(1,1)=EE(3,1)+E2(1,1)*GRD(1,1,1)+E2(1,2)*GRD(2,1,1)
            E1(1,2)=EE(3,2)+E2(1,1)*GRD(1,2,1)+E2(1,2)*GRD(2,2,1)
            E1(2,1)=EE(4,1)+E2(2,1)*GRD(1,1,1)+E2(2,2)*GRD(2,1,1)
            E1(2,2)=EE(4,2)+E2(2,1)*GRD(1,2,1)+E2(2,2)*GRD(2,2,1)
            DT=E1(1,1)*E1(2,2)-E1(1,2)*E1(2,1)
            E2(1,1)= E1(2,2)/DT
            E2(1,2)=-E1(1,2)/DT
            E2(2,1)=-E1(2,1)/DT
            E2(2,2)= E1(1,1)/DT
C
            CDSDX(K,1,M)=E2(1,1)*DQX
            CDSDX(K,2,M)=E2(2,1)*DQX
            CUSDX(K,1,M)=GRD(1,1,1)*CDSDX(K,1,M)
     *                  +GRD(1,2,1)*CDSDX(K,2,M)
            CUSDX(K,2,M)=GRD(2,1,1)*CDSDX(K,1,M)
     *                  +GRD(2,2,1)*CDSDX(K,2,M)
            CDSDZ(K,1,M)=E2(1,2)*DQZ
            CDSDZ(K,2,M)=E2(2,2)*DQZ
            CUSDZ(K,1,M)=GRD(1,1,1)*CDSDZ(K,1,M)
     *                  +GRD(1,2,1)*CDSDZ(K,2,M)
            CUSDZ(K,2,M)=GRD(2,1,1)*CDSDZ(K,1,M)
     *                  +GRD(2,2,1)*CDSDZ(K,2,M)
C
          END IF
C 
        ELSE
C
          IF(LS.EQ.NL)THEN 
C
            CALL DDUPSV(OM,WN,SDEP,CMS,CMP,DD)
C
            E1(1,1)=DD(1,1)*GRU(1,1,LS-1)+DD(1,2)*GRU(2,1,LS-1)
            E1(1,2)=DD(1,1)*GRU(1,2,LS-1)+DD(1,2)*GRU(2,2,LS-1)
            E1(2,1)=DD(2,1)*GRU(1,1,LS-1)+DD(2,2)*GRU(2,1,LS-1)
            E1(2,2)=DD(2,1)*GRU(1,2,LS-1)+DD(2,2)*GRU(2,2,LS-1)
C  
            AU(1,1)=EE(1,1)*E1(1,1)+EE(1,2)*E1(2,1)+EE(1,3)
            AU(1,2)=EE(1,1)*E1(1,2)+EE(1,2)*E1(2,2)+EE(1,4)
            AU(2,1)=EE(2,1)*E1(1,1)+EE(2,2)*E1(2,1)+EE(2,3)
            AU(2,2)=EE(2,1)*E1(1,2)+EE(2,2)*E1(2,2)+EE(2,4)
            BU(1,1)=EE(3,1)*E1(1,1)+EE(3,2)*E1(2,1)+EE(3,3)
            BU(1,2)=EE(3,1)*E1(1,2)+EE(3,2)*E1(2,2)+EE(3,4)
            BU(2,1)=EE(4,1)*E1(1,1)+EE(4,2)*E1(2,1)+EE(4,3)
            BU(2,2)=EE(4,1)*E1(1,2)+EE(4,2)*E1(2,2)+EE(4,4)
            AD(1,1)=EE(1,1)
            AD(1,2)=EE(1,2)
            AD(2,1)=EE(2,1)
            AD(2,2)=EE(2,2)
            BD(1,1)=EE(3,1)
            BD(1,2)=EE(3,2)
            BD(2,1)=EE(4,1)
            BD(2,2)=EE(4,2)
C
            DT=AD(1,1)*AD(2,2)-AD(1,2)*AD(2,1)
            E1(1,1)= AD(2,2)/DT
            E1(1,2)=-AD(1,2)/DT
            E1(2,1)=-AD(2,1)/DT
            E1(2,2)= AD(1,1)/DT
C
            CS(1,1)=E1(1,1)*AU(1,1)+E1(1,2)*AU(2,1)
            CS(1,2)=E1(1,1)*AU(1,2)+E1(1,2)*AU(2,2)
            CS(2,1)=E1(2,1)*AU(1,1)+E1(2,2)*AU(2,1)
            CS(2,2)=E1(2,1)*AU(1,2)+E1(2,2)*AU(2,2)
C
            E1(1,1)=BD(1,1)*CS(1,1)+BD(1,2)*CS(2,1)-BU(1,1)
            E1(1,2)=BD(1,1)*CS(1,2)+BD(1,2)*CS(2,2)-BU(1,2)
            E1(2,1)=BD(2,1)*CS(1,1)+BD(2,2)*CS(2,1)-BU(2,1)
            E1(2,2)=BD(2,1)*CS(1,2)+BD(2,2)*CS(2,2)-BU(2,2)
            DT=E1(1,1)*E1(2,2)-E1(1,2)*E1(2,1)
            E2(1,1)= E1(2,2)/DT
            E2(1,2)=-E1(1,2)/DT
            E2(2,1)=-E1(2,1)/DT
            E2(2,2)= E1(1,1)/DT
C
            CUSUX(K,1,M)=E2(1,1)*DQX
            CUSUX(K,2,M)=E2(2,1)*DQX
            CDSUX(K,1,M)=GRU(1,1,LS-1)*CUSUX(K,1,M)
     *                  +GRU(1,2,LS-1)*CUSUX(K,2,M)
            CDSUX(K,2,M)=GRU(2,1,LS-1)*CUSUX(K,1,M)
     *                  +GRU(2,2,LS-1)*CUSUX(K,2,M)
            CDSDX(K,1,M)=CS(1,1)*CUSUX(K,1,M)+CS(1,2)*CUSUX(K,2,M)
            CDSDX(K,2,M)=CS(2,1)*CUSUX(K,1,M)+CS(2,2)*CUSUX(K,2,M)
C
            CUSUZ(K,1,M)=E2(1,2)*DQZ
            CUSUZ(K,2,M)=E2(2,2)*DQZ
            CDSUZ(K,1,M)=GRU(1,1,LS-1)*CUSUZ(K,1,M)
     *                  +GRU(1,2,LS-1)*CUSUZ(K,2,M)
            CDSUZ(K,2,M)=GRU(2,1,LS-1)*CUSUZ(K,1,M)
     *                  +GRU(2,2,LS-1)*CUSUZ(K,2,M)
            CDSDZ(K,1,M)=CS(1,1)*CUSUZ(K,1,M)+CS(1,2)*CUSUZ(K,2,M)
            CDSDZ(K,2,M)=CS(2,1)*CUSUZ(K,1,M)+CS(2,2)*CUSUZ(K,2,M)
C
          ELSE
C
            CALL DDUPSV(OM,WN,SDEP,CMS,CMP,DD)
            CALL DDUPSV(OM,WN,THK(LS)-SDEP,CMS,CMP,DU)
C
            E1(1,1)=DD(1,1)*GRU(1,1,LS-1)+DD(1,2)*GRU(2,1,LS-1)
            E1(1,2)=DD(1,1)*GRU(1,2,LS-1)+DD(1,2)*GRU(2,2,LS-1)
            E1(2,1)=DD(2,1)*GRU(1,1,LS-1)+DD(2,2)*GRU(2,1,LS-1)
            E1(2,2)=DD(2,1)*GRU(1,2,LS-1)+DD(2,2)*GRU(2,2,LS-1)
C
            AU(1,1)=EE(1,1)*E1(1,1)+EE(1,2)*E1(2,1)+EE(1,3)
            AU(1,2)=EE(1,1)*E1(1,2)+EE(1,2)*E1(2,2)+EE(1,4)
            AU(2,1)=EE(2,1)*E1(1,1)+EE(2,2)*E1(2,1)+EE(2,3)
            AU(2,2)=EE(2,1)*E1(1,2)+EE(2,2)*E1(2,2)+EE(2,4)
            BU(1,1)=EE(3,1)*E1(1,1)+EE(3,2)*E1(2,1)+EE(3,3)
            BU(1,2)=EE(3,1)*E1(1,2)+EE(3,2)*E1(2,2)+EE(3,4)
            BU(2,1)=EE(4,1)*E1(1,1)+EE(4,2)*E1(2,1)+EE(4,3)
            BU(2,2)=EE(4,1)*E1(1,2)+EE(4,2)*E1(2,2)+EE(4,4)
C
            E1(1,1)=DU(1,1)*GRD(1,1,LS)+DU(1,2)*GRD(2,1,LS)
            E1(1,2)=DU(1,1)*GRD(1,2,LS)+DU(1,2)*GRD(2,2,LS)
            E1(2,1)=DU(2,1)*GRD(1,1,LS)+DU(2,2)*GRD(2,1,LS)
            E1(2,2)=DU(2,1)*GRD(1,2,LS)+DU(2,2)*GRD(2,2,LS)
C
            AD(1,1)=EE(1,3)*E1(1,1)+EE(1,4)*E1(2,1)+EE(1,1)
            AD(1,2)=EE(1,3)*E1(1,2)+EE(1,4)*E1(2,2)+EE(1,2)
            AD(2,1)=EE(2,3)*E1(1,1)+EE(2,4)*E1(2,1)+EE(2,1)
            AD(2,2)=EE(2,3)*E1(1,2)+EE(2,4)*E1(2,2)+EE(2,2)
            BD(1,1)=EE(3,3)*E1(1,1)+EE(3,4)*E1(2,1)+EE(3,1)
            BD(1,2)=EE(3,3)*E1(1,2)+EE(3,4)*E1(2,2)+EE(3,2)
            BD(2,1)=EE(4,3)*E1(1,1)+EE(4,4)*E1(2,1)+EE(4,1)
            BD(2,2)=EE(4,3)*E1(1,2)+EE(4,4)*E1(2,2)+EE(4,2)
C
            DT=AD(1,1)*AD(2,2)-AD(1,2)*AD(2,1)
            E1(1,1)= AD(2,2)/DT
            E1(1,2)=-AD(1,2)/DT
            E1(2,1)=-AD(2,1)/DT
            E1(2,2)= AD(1,1)/DT
            CS(1,1)=E1(1,1)*AU(1,1)+E1(1,2)*AU(2,1)
            CS(1,2)=E1(1,1)*AU(1,2)+E1(1,2)*AU(2,2)
            CS(2,1)=E1(2,1)*AU(1,1)+E1(2,2)*AU(2,1)
            CS(2,2)=E1(2,1)*AU(1,2)+E1(2,2)*AU(2,2)
C
            E1(1,1)=BD(1,1)*CS(1,1)+BD(1,2)*CS(2,1)-BU(1,1)
            E1(1,2)=BD(1,1)*CS(1,2)+BD(1,2)*CS(2,2)-BU(1,2)
            E1(2,1)=BD(2,1)*CS(1,1)+BD(2,2)*CS(2,1)-BU(2,1)
            E1(2,2)=BD(2,1)*CS(1,2)+BD(2,2)*CS(2,2)-BU(2,2)
            DT=E1(1,1)*E1(2,2)-E1(1,2)*E1(2,1)
            E2(1,1)= E1(2,2)/DT
            E2(1,2)=-E1(1,2)/DT
            E2(2,1)=-E1(2,1)/DT
            E2(2,2)= E1(1,1)/DT
C
            CUSUX(K,1,M)=E2(1,1)*DQX
            CUSUX(K,2,M)=E2(2,1)*DQX
            CDSUX(K,1,M)=GRU(1,1,LS-1)*CUSUX(K,1,M)
     *                  +GRU(1,2,LS-1)*CUSUX(K,2,M)
            CDSUX(K,2,M)=GRU(2,1,LS-1)*CUSUX(K,1,M)
     *                  +GRU(2,2,LS-1)*CUSUX(K,2,M)
            CDSDX(K,1,M)=CS(1,1)*CUSUX(K,1,M)+CS(1,2)*CUSUX(K,2,M)
            CDSDX(K,2,M)=CS(2,1)*CUSUX(K,1,M)+CS(2,2)*CUSUX(K,2,M)
            CUSDX(K,1,M)=GRD(1,1,LS)*CDSDX(K,1,M)
     *                  +GRD(1,2,LS)*CDSDX(K,2,M)
            CUSDX(K,2,M)=GRD(2,1,LS)*CDSDX(K,1,M)
     *                  +GRD(2,2,LS)*CDSDX(K,2,M)
C
            CUSUZ(K,1,M)=E2(1,2)*DQZ
            CUSUZ(K,2,M)=E2(2,2)*DQZ
            CDSUZ(K,1,M)=GRU(1,1,LS-1)*CUSUZ(K,1,M)
     *                  +GRU(1,2,LS-1)*CUSUZ(K,2,M)
            CDSUZ(K,2,M)=GRU(2,1,LS-1)*CUSUZ(K,1,M)
     *                  +GRU(2,2,LS-1)*CUSUZ(K,2,M)
            CDSDZ(K,1,M)=CS(1,1)*CUSUZ(K,1,M)+CS(1,2)*CUSUZ(K,2,M)
            CDSDZ(K,2,M)=CS(2,1)*CUSUZ(K,1,M)+CS(2,2)*CUSUZ(K,2,M)
            CUSDZ(K,1,M)=GRD(1,1,LS)*CDSDZ(K,1,M)
     *                  +GRD(1,2,LS)*CDSDZ(K,2,M)
            CUSDZ(K,2,M)=GRD(2,1,LS)*CDSDZ(K,1,M)
     *                  +GRD(2,2,LS)*CDSDZ(K,2,M)
C
          ENDIF
C
        END IF
C
        IF(LS.EQ.1)GOTO 10
          CUX(K,1,LS-1,M)=GTU(1,1,LS-1)*CUSUX(K,1,M)
     *                   +GTU(1,2,LS-1)*CUSUX(K,2,M)
          CUX(K,2,LS-1,M)=GTU(2,1,LS-1)*CUSUX(K,1,M)
     *                   +GTU(2,2,LS-1)*CUSUX(K,2,M)
          CUZ(K,1,LS-1,M)=GTU(1,1,LS-1)*CUSUZ(K,1,M)
     *                   +GTU(1,2,LS-1)*CUSUZ(K,2,M)
          CUZ(K,2,LS-1,M)=GTU(2,1,LS-1)*CUSUZ(K,1,M)
     *                   +GTU(2,2,LS-1)*CUSUZ(K,2,M)
        DO 110 I=LS-2,1,-1
          CUX(K,1,I,M)  =GTU(1,1,I)*CUX(K,1,I+1,M)
     *                  +GTU(1,2,I)*CUX(K,2,I+1,M)
          CUX(K,2,I,M)  =GTU(2,1,I)*CUX(K,1,I+1,M)
     *                  +GTU(2,2,I)*CUX(K,2,I+1,M)
          CDX(K,1,I+1,M)=GRU(1,1,I)*CUX(K,1,I+1,M)
     *                  +GRU(1,2,I)*CUX(K,2,I+1,M)
          CDX(K,2,I+1,M)=GRU(2,1,I)*CUX(K,1,I+1,M)
     *                  +GRU(2,2,I)*CUX(K,2,I+1,M)
          CUZ(K,1,I,M)  =GTU(1,1,I)*CUZ(K,1,I+1,M)
     *                  +GTU(1,2,I)*CUZ(K,2,I+1,M)
          CUZ(K,2,I,M)  =GTU(2,1,I)*CUZ(K,1,I+1,M)
     *                  +GTU(2,2,I)*CUZ(K,2,I+1,M)
          CDZ(K,1,I+1,M)=GRU(1,1,I)*CUZ(K,1,I+1,M)
     *                  +GRU(1,2,I)*CUZ(K,2,I+1,M)
          CDZ(K,2,I+1,M)=GRU(2,1,I)*CUZ(K,1,I+1,M)
     *                  +GRU(2,2,I)*CUZ(K,2,I+1,M)
  110   CONTINUE
        CDX(K,1,1,M)=GRU(1,1,0)*CUX(K,1,1,M)+GRU(1,2,0)*CUX(K,2,1,M)
        CDX(K,2,1,M)=GRU(2,1,0)*CUX(K,1,1,M)+GRU(2,2,0)*CUX(K,2,1,M)
        CDZ(K,1,1,M)=GRU(1,1,0)*CUZ(K,1,1,M)+GRU(1,2,0)*CUZ(K,2,1,M)
        CDZ(K,2,1,M)=GRU(2,1,0)*CUZ(K,1,1,M)+GRU(2,2,0)*CUZ(K,2,1,M)
C
   10   IF(LS.EQ.NL)GOTO 100
        CDX(K,1,LS+1,M)=GTD(1,1,LS)*CDSDX(K,1,M)
     *                 +GTD(1,2,LS)*CDSDX(K,2,M)
        CDX(K,2,LS+1,M)=GTD(2,1,LS)*CDSDX(K,1,M)
     *                 +GTD(2,2,LS)*CDSDX(K,2,M)
        CDZ(K,1,LS+1,M)=GTD(1,1,LS)*CDSDZ(K,1,M)
     *                 +GTD(1,2,LS)*CDSDZ(K,2,M)
        CDZ(K,2,LS+1,M)=GTD(2,1,LS)*CDSDZ(K,1,M)
     *                 +GTD(2,2,LS)*CDSDZ(K,2,M)
        DO 120 I=LS+1,NL-1
          CDX(K,1,I+1,M)=GTD(1,1,I)*CDX(K,1,I,M)
     *                  +GTD(1,2,I)*CDX(K,2,I,M)
          CDX(K,2,I+1,M)=GTD(2,1,I)*CDX(K,1,I,M)
     *                  +GTD(2,2,I)*CDX(K,2,I,M)
          CUX(K,1,I,M)  =GRD(1,1,I)*CDX(K,1,I,M)
     *                  +GRD(1,2,I)*CDX(K,2,I,M)
          CUX(K,2,I,M)  =GRD(2,1,I)*CDX(K,1,I,M)
     *                  +GRD(2,2,I)*CDX(K,2,I,M)
          CDZ(K,1,I+1,M)=GTD(1,1,I)*CDZ(K,1,I,M)
     *                  +GTD(1,2,I)*CDZ(K,2,I,M)
          CDZ(K,2,I+1,M)=GTD(2,1,I)*CDZ(K,1,I,M)
     *                  +GTD(2,2,I)*CDZ(K,2,I,M)
          CUZ(K,1,I,M)  =GRD(1,1,I)*CDZ(K,1,I,M)
     *                  +GRD(1,2,I)*CDZ(K,2,I,M)
          CUZ(K,2,I,M)  =GRD(2,1,I)*CDZ(K,1,I,M)
     *                  +GRD(2,2,I)*CDZ(K,2,I,M)
  120   CONTINUE
C
  100 CONTINUE
C
      RETURN
      END
C
C
C *** THE ASYMPTOTIC TRACTION GREEN FUNCTION ***
C
      SUBROUTINE GRNN(OM,UU,PP,RX,RY,XM,YM,ZM)
C
      COMPLEX UU(3,3),PP(3,3),VP,VS,A,B,VP2,VS2,SM,RM
     *    ,QX1(0:2),QZ1(0:2),VX1(0:2),WX1(0:2),WZ1(0:2)
     *    ,QX2(0:2),QZ2(0:2),VX2(0:2),WX2(0:2),WZ2(0:2)
     *    ,QXS(0:2),QZS(0:2),VXS(0:2),WXS(0:2),WZS(0:2)
     *    ,QX(0:3),QY(0:3),QZ(0:3),VX(0:3),VY(0:3)
     *    ,WX(0:3),WY(0:3),WZ(0:3),UX(3,3),UY(3,3),UZ(3,3)
      COMMON /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /DPSO/DEP1,DEP2,SDP,ODP /SOLY/LS,SDEP,LO,ODEP
     *    /INTG/C11,N11,C12,N12 /INTG2/I12,WNB2,N21,WNC2,N22
     *    /IASYM/IST /FCQVW/SM,RM,RR
C
C *** CHECK OF DIMENSION ***
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM DRTGRN:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
C *** GREEN FUNCTION ***
C
      VS2= VS(LO)*VS(LO)
      SM = DNS(LO)*VS2
      VP2= VP(LO)*VP(LO)
      RM = DNS(LO)*VP2-2.0*SM
C
      RR=SQRT(RX*RX+RY*RY)
C
      IF(I12.EQ.1)THEN
        N1=N11
        N2=N12
        WNB=OM/C12
        WNA=WNB/(1000.0*N1)
        WNC=OM/C11
      ELSE
        N1=N21
        N2=N22
        WNB=WNB2
        WNA=WNB/(1000.0*N1)
        WNC=WNC2
      END IF
C
      IF((IST.EQ.1).AND.(IABS(LS-LO).LE.1))THEN
        CALL CASYM(LS,NL)
      END IF
C
      CALL QVWRZ(OM,WNA,WNB,N1,QX1,QZ1,VX1,WX1,WZ1,1)
      CALL QVWRZ(OM,WNB,WNC,N2,QX2,QZ2,VX2,WX2,WZ2,2)
C
      DO 150 J=0,2
       QXS(J)=(0.0,0.0)
       VXS(J)=(0.0,0.0)
       WXS(J)=(0.0,0.0)
       QZS(J)=(0.0,0.0)
       WZS(J)=(0.0,0.0)
  150 CONTINUE   
C
      IF((IST.EQ.1).AND.(IABS(LS-LO).LE.1))THEN
        CALL AINTG(RR,LS,NL,QXS,QZS,VXS,WXS,WZS)
      END IF
C
      IF(RR.EQ.0.0)THEN
        CR=0.0
        SR=0.0
        C2=0.0
        S2=0.0
        CS=0.0
        CX=0.0
        SY=0.0
        CY=0.0
      ELSE
        CR=RX/RR
        SR=RY/RR
        C2=CR*CR
        S2=SR*SR
        CS=CR*SR
        CX=S2/RR
        SY=C2/RR
        CY=-CS/RR
      END IF
      SX=CY
C
      A=QX1(0)+QX2(0)+QXS(0)
      QX(0)=A*CR
      QY(0)=A*SR
      B=QX1(1)+QX2(1)+QXS(1)
      QX(1)=B*C2+A*CX
      QY(1)=B*CS+A*SX
      QX(2)=B*CS+A*CY
      QY(2)=B*S2+A*SY
      B=QX1(2)+QX2(2)+QXS(2)
      QX(3)= B*CR
      QY(3)= B*SR
C
      QZ(0)=-(QZ1(0)+QZ2(0)+QZS(0))
      B=QZ1(1)+QZ2(1)+QZS(1)
      QZ(1)=-B*CR
      QZ(2)=-B*SR
      QZ(3)=-(QZ1(2)+QZ2(2)+QZS(2))
C
      A=VX1(0)+VX2(0)+VXS(0)
      VX(0)=-A*SR
      VY(0)= A*CR
      B=VX1(1)+VX2(1)+VXS(1)
      VX(1)=-(B*CS+A*SX)
      VY(1)=  B*C2+A*CX
      VX(2)=-(B*S2+A*SY)
      VY(2)=  B*CS+A*CY
      B=VX1(2)+VX2(2)+VXS(2)
      VX(3)=-B*SR
      VY(3)= B*CR
C
      A=WX1(0)+WX2(0)+WXS(0)
      WX(0)=-A*CR
      WY(0)=-A*SR
      B=WX1(1)+WX2(1)+WXS(1)
      WX(1)=-(B*C2+A*CX)
      WY(1)=-(B*CS+A*SX)
      WX(2)=-(B*CS+A*CY)
      WY(2)=-(B*S2+A*SY)
      B=WX1(2)+WX2(2)+WXS(2)
      WX(3)=-B*CR
      WY(3)=-B*SR
C
      WZ(0)=-(WZ1(0)+WZ2(0)+WZS(0))
      B=WZ1(1)+WZ2(1)+WZS(1)
      WZ(1)=-B*CR
      WZ(2)=-B*SR
      WZ(3)=-(WZ1(2)+WZ2(2)+WZS(2))
C
      UU(1,1)=QX(0)*CR-VX(0)*SR
      UU(1,2)=QY(0)*CR-VY(0)*SR
      UU(1,3)=QZ(0)*CR
      UU(2,1)=QX(0)*SR+VX(0)*CR
      UU(2,2)=QY(0)*SR+VY(0)*CR
      UU(2,3)=QZ(0)*SR
      UU(3,1)=WX(0)
      UU(3,2)=WY(0)
      UU(3,3)=WZ(0)
C
      UX(1,1)=QX(1)*CR+QX(0)*CX-VX(1)*SR-VX(0)*SX
      UX(1,2)=QX(2)*CR+QX(0)*CY-VX(2)*SR-VX(0)*SY
      UX(1,3)=QX(3)*CR-VX(3)*SR
      UY(1,1)=QY(1)*CR+QY(0)*CX-VY(1)*SR-VY(0)*SX
      UY(1,2)=QY(2)*CR+QY(0)*CY-VY(2)*SR-VY(0)*SY
      UY(1,3)=QY(3)*CR-VY(3)*SR
      UZ(1,1)=QZ(1)*CR+QZ(0)*CX
      UZ(1,2)=QZ(2)*CR+QZ(0)*CY
      UZ(1,3)=QZ(3)*CR
C
      UX(2,1)=QX(1)*SR+QX(0)*SX+VX(1)*CR+VX(0)*CX
      UX(2,2)=QX(2)*SR+QX(0)*SY+VX(2)*CR+VX(0)*CY
      UX(2,3)=QX(3)*SR+VX(3)*CR
      UY(2,1)=QY(1)*SR+QY(0)*SX+VY(1)*CR+VY(0)*CX
      UY(2,2)=QY(2)*SR+QY(0)*SY+VY(2)*CR+VY(0)*CY
      UY(2,3)=QY(3)*SR+VY(3)*CR
      UZ(2,1)=QZ(1)*SR+QZ(0)*SX
      UZ(2,2)=QZ(2)*SR+QZ(0)*SY
      UZ(2,3)=QZ(3)*SR
C
      UX(3,1)=WX(1)
      UX(3,2)=WX(2)
      UX(3,3)=WX(3)
      UY(3,1)=WY(1)
      UY(3,2)=WY(2)
      UY(3,3)=WY(3)
      UZ(3,1)=WZ(1)
      UZ(3,2)=WZ(2)
      UZ(3,3)=WZ(3)
C
      A=(UX(1,1)+UX(2,2)+UX(3,3))*RM
      B=SM*(2.0*UX(1,1)*XM+(UX(1,2)+UX(2,1))*YM+(UX(1,3)+UX(3,1))*ZM)
      PP(1,1)=A*XM+B
      B=SM*((UX(2,1)+UX(1,2))*XM+2.0*UX(2,2)*YM+(UX(2,3)+UX(3,2))*ZM)
      PP(2,1)=A*YM+B
      B=SM*((UX(3,1)+UX(1,3))*XM+(UX(3,2)+UX(2,3))*YM+2.0*UX(3,3)*ZM)
      PP(3,1)=A*ZM+B
C
      A=(UY(1,1)+UY(2,2)+UY(3,3))*RM
      B=SM*(2.0*UY(1,1)*XM+(UY(1,2)+UY(2,1))*YM+(UY(1,3)+UY(3,1))*ZM)
      PP(1,2)=A*XM+B
      B=SM*((UY(2,1)+UY(1,2))*XM+2.0*UY(2,2)*YM+(UY(2,3)+UY(3,2))*ZM)
      PP(2,2)=A*YM+B
      B=SM*((UY(3,1)+UY(1,3))*XM+(UY(3,2)+UY(2,3))*YM+2.0*UY(3,3)*ZM)
      PP(3,2)=A*ZM+B
C
      A=(UZ(1,1)+UZ(2,2)+UZ(3,3))*RM
      B=SM*(2.0*UZ(1,1)*XM+(UZ(1,2)+UZ(2,1))*YM+(UZ(1,3)+UZ(3,1))*ZM)
      PP(1,3)=A*XM+B
      B=SM*((UZ(2,1)+UZ(1,2))*XM+2.0*UZ(2,2)*YM+(UZ(2,3)+UZ(3,2))*ZM)
      PP(2,3)=A*YM+B
      B=SM*((UZ(3,1)+UZ(1,3))*XM+(UZ(3,2)+UZ(2,3))*YM+2.0*UZ(3,3)*ZM)
      PP(3,3)=A*ZM+B
C
      RETURN
      END
C
C
C
C *** THE COMPUTATION OF Q, V, AND W AND THEIR DERIVATIVES 
C     USING SIMPSON METHOD ***
C
      SUBROUTINE QVWRZ(OM,A,B,N,GQX,GQZ,GVX,GWX,GWZ,M)
C     
      COMPLEX GQX(0:2),GQZ(0:2),GVX(0:2),GWX(0:2),GWZ(0:2)
     *          ,QXA(0:2),QZA(0:2),VXA(0:2),WXA(0:2),WZA(0:2)
     *          ,QXB(0:2),QZB(0:2),VXB(0:2),WXB(0:2),WZB(0:2)
     *          ,QXC(0:2),QZC(0:2),VXC(0:2),WXC(0:2),WZC(0:2)
C
      DO 100 J=0,2
        GQX(J)=(0.0,0.0)
        GQZ(J)=(0.0,0.0)
        GVX(J)=(0.0,0.0)
        GWX(J)=(0.0,0.0)
        GWZ(J)=(0.0,0.0)
  100 CONTINUE
C
      H=(B-A)/N
      CALL FQVWRZ(OM,1,A,QXA,QZA,VXA,WXA,WZA,N,M)
      DO  300 I=1,N
        X=A+H*(FLOAT(I)-0.50)
        K=2*I
        CALL FQVWRZ(OM,K,X,QXB,QZB,VXB,WXB,WZB,N,M)
        X=A+H*FLOAT(I)
        K=K+1
        CALL FQVWRZ(OM,K,X,QXC,QZC,VXC,WXC,WZC,N,M)
        DO 310 J=0,2
         GQX(J)= GQX(J)+H*(QXA(J)+4.0*QXB(J)+QXC(J))/6.0
         GVX(J)= GVX(J)+H*(VXA(J)+4.0*VXB(J)+VXC(J))/6.0
         GWX(J)= GWX(J)+H*(WXA(J)+4.0*WXB(J)+WXC(J))/6.0
         GQZ(J)= GQZ(J)+H*(QZA(J)+4.0*QZB(J)+QZC(J))/6.0
         GWZ(J)= GWZ(J)+H*(WZA(J)+4.0*WZB(J)+WZC(J))/6.0
         QXA(J)= QXC(J)
         VXA(J)= VXC(J)
         WXA(J)= WXC(J)
         QZA(J)= QZC(J)
         WZA(J)= WZC(J)
  310   CONTINUE
  300 CONTINUE
C
      RETURN
      END
C
C
C
C *** THE INTEGRANDS OF Q, V, AND W AND THEIR DERIVATIVES ***
C
      SUBROUTINE FQVWRZ(OM,K,WN,QX,QZ,VX,WX,WZ,N,M)
C
      COMPLEX QX(0:2),QZ(0:2),VX(0:2),WX(0:2),WZ(0:2)
     *   ,VLX(2),URX(2,2),URZ(2,2),VLXZ,URXZ(2),URZZ(2),SM,RAM
     *   ,H1X,H2X,V1X,V2X,V3X,V4X,V1Z,V2Z,V3Z,V4Z,VP,VS
      DIMENSION BJ0(0:1),BJ1(0:1),BJK(0:1),BJD(0:1)
      COMMON /IASYM/IST /FCQVW/SM,RAM,RR /SOLY/LS,SDEP,LO,ODEP
     *       /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
C
C *** CHECK OF DIMENSION ***
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM FQVWRZ:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
      CALL RTSH(OM,K,WN,VLX,N,M)
      CALL RTPSV(OM,K,WN,URX,URZ,N,M)
C
      IF((IST.EQ.1).AND.(IABS(LS-LO).LE.1))THEN
        CALL ASYM(LS,NL,WN,H1X,H2X,V1X,V2X,V3X,V4X,V1Z,V2Z,V3Z,V4Z)
        VLX(1)=VLX(1)-H1X
        URX(1,1)=URX(1,1)-V1X
        URX(2,1)=URX(2,1)-V2X
        URZ(1,1)=URZ(1,1)-V1Z
        URZ(2,1)=URZ(2,1)-V2Z
        VLX(2)=VLX(2)-H2X
        URX(1,2)=URX(1,2)-V3X
        URX(2,2)=URX(2,2)-V4X
        URZ(1,2)=URZ(1,2)-V3Z
        URZ(2,2)=URZ(2,2)-V4Z
      END IF
C
      VLXZ=VLX(2)/SM
      URXZ(1)=URX(1,2)/SM+WN*URX(2,1)
      URZZ(1)=URZ(1,2)/SM+WN*URZ(2,1)
      URXZ(2)=(URX(2,2)-WN*RAM*URX(1,1))/(RAM+2.0*SM)
      URZZ(2)=(URZ(2,2)-WN*RAM*URZ(1,1))/(RAM+2.0*SM)
C
      RK=WN*RR
      BJ0(0)=BSJ0(RK)
      BJ1(0)=BSJ1(RK)
      IF(RK.EQ.0.0)THEN
        BJK(0)=0.5
      ELSE
        BJK(0)=BJ1(0)/RK
      END IF
      BJD(0)=BJ0(0)-BJK(0)
C
      BJ0(1)=-BJ1(0)*WN
      BJ1(1)= BJD(0)*WN
      IF(RK.EQ.0.0)THEN
        BJK(1)=0.0
      ELSE
        BJK(1)=(BJ1(1)-BJ1(0)/RR)/RK
      END IF
      BJD(1)= BJ0(1)-BJK(1)
C
      QX(0)= URX(1,1)*BJD(0)+VLX(1)*BJK(0)
      VX(0)= URX(1,1)*BJK(0)+VLX(1)*BJD(0)
      WX(0)= URX(2,1)*BJ1(0)
      QZ(0)= URZ(1,1)*BJ1(0)
      WZ(0)= URZ(2,1)*BJ0(0)
C
      QX(1)= URX(1,1)*BJD(1)+VLX(1)*BJK(1)
      VX(1)= URX(1,1)*BJK(1)+VLX(1)*BJD(1)
      WX(1)= URX(2,1)*BJ1(1)
      QZ(1)= URZ(1,1)*BJ1(1)
      WZ(1)= URZ(2,1)*BJ0(1)
C
      QX(2)= URXZ(1)*BJD(0)+VLXZ*BJK(0)
      VX(2)= URXZ(1)*BJK(0)+VLXZ*BJD(0)
      WX(2)= URXZ(2)*BJ1(0)
      QZ(2)= URZZ(1)*BJ1(0)
      WZ(2)= URZZ(2)*BJ0(0)
C
      RETURN
      END
C
C *** SH DISPLACEMENT USING R/T MATRIX ***
C
      SUBROUTINE RTSH(OM,K,WN,VLX,NWN,M)
C
      COMPLEX VP,VS,CD,CU,VS2,WS2,CMS,SM,EE(2,2)
     *       ,CUSU,CDSU,CDSD,CUSD,DD,DU,VLX(2)
      COMMON /SOLY/LS,SDEP,LO,ODEP
     *    /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
      COMMON /DUSH/CD(510,20,2),CU(510,20,2)
     *       ,CUSU(510,2),CDSU(510,2),CDSD(510,2),CUSD(510,2)
C
C *** CHECK FOR THE DIMENSION OF CD AND CU ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM RTSH: NL.GT.NC ',NL,NC
         STOP
      END IF
C
      NC=510
      NN=NWN*2+1
      IF(NN.GT.NC)THEN
         WRITE(1,*)' FROM RTPSV: NWN*2+1.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** COMPUTATION OF VLX ***
C
      OM2=OM*OM
      WN2=WN*WN
C
      VS2=VS(LO)*VS(LO)
      WS2=OM2/VS2
      CMS=CSQRT(WN2-WS2)
      IF(REAL(CMS).LT.0.0)CMS=-CMS
C
      SM=DNS(LO)*VS2
      EE(1,1)=(1.0,0.0)
      EE(1,2)=(1.0,0.0)
      EE(2,1)=-SM*CMS
      EE(2,2)= SM*CMS
C
      IF(LO.EQ.NL)THEN
C        
        IF(LO.NE.LS)THEN
          DD=CEXP(-CMS*ODEP)
          VLX(1)=EE(1,1)*DD*CD(K,LO,M)
          VLX(2)=EE(2,1)*DD*CD(K,LO,M)
        ELSE
          IF(ODEP.GE.SDEP)THEN
            DD=CEXP(-CMS*(ODEP-SDEP))
            VLX(1)=EE(1,1)*DD*CDSD(K,M)
            VLX(2)=EE(2,1)*DD*CDSD(K,M)
          ELSE
            DD=CEXP(-CMS*ODEP)
            DU=CEXP(-CMS*(SDEP-ODEP))
            VLX(1)=EE(1,1)*DD*CDSU(K,M)+EE(1,2)*DU*CUSU(K,M)
            VLX(2)=EE(2,1)*DD*CDSU(K,M)+EE(2,2)*DU*CUSU(K,M)
          END IF
        END IF
C
      ELSE
C        
        IF(LO.NE.LS)THEN
          DD=CEXP(-CMS*ODEP)
          DU=CEXP(-CMS*(THK(LO)-ODEP))
          VLX(1)=EE(1,1)*DD*CD(K,LO,M)+EE(1,2)*DU*CU(K,LO,M)
          VLX(2)=EE(2,1)*DD*CD(K,LO,M)+EE(2,2)*DU*CU(K,LO,M)
        ELSE
          IF(ODEP.GE.SDEP)THEN
            DD=CEXP(-CMS*(ODEP-SDEP))
            DU=CEXP(-CMS*(THK(LO)-ODEP))
            VLX(1)=EE(1,1)*DD*CDSD(K,M)+EE(1,2)*DU*CUSD(K,M)
            VLX(2)=EE(2,1)*DD*CDSD(K,M)+EE(2,2)*DU*CUSD(K,M)
          ELSE
            DD=CEXP(-CMS*ODEP)
            DU=CEXP(-CMS*(SDEP-ODEP))
            VLX(1)=EE(1,1)*DD*CDSU(K,M)+EE(1,2)*DU*CUSU(K,M)
            VLX(2)=EE(2,1)*DD*CDSU(K,M)+EE(2,2)*DU*CUSU(K,M)
          END IF
        END IF
C
      END IF
C
      RETURN
      END
C
C
C *** PSV DISPLACEMENT USING R/T MATRIX ***
C
      SUBROUTINE RTPSV(OM,K,WN,URX,URZ,NWN,M)
C
      COMPLEX VP,VS,CMP,CMS,EE(4,4),DD(2,2),DU(2,2)
     *    ,CDX,CUX,CUSUX,CDSUX,CDSDX,CUSDX,URX(2,2),E1(2,2)
     *    ,CDZ,CUZ,CUSUZ,CDSUZ,CDSDZ,CUSDZ,URZ(2,2),E2(2,2)
      COMMON /SOLY/LS,SDEP,LO,ODEP
     * /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     * /DUPSVX/CDX(510,2,20,2),CUX(510,2,20,2),CUSUX(510,2,2)
     *        ,CDSUX(510,2,2),CDSDX(510,2,2),CUSDX(510,2,2) 
     * /DUPSVZ/CDZ(510,2,20,2),CUZ(510,2,20,2),CUSUZ(510,2,2)
     *        ,CDSUZ(510,2,2),CDSDZ(510,2,2),CUSDZ(510,2,2) 
C
C *** CHECK FOR THE DIMENSION OF CD AND CU ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM RTPSV: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
      NC=510
      NN=NWN*2+1
      IF(NN.GT.NC)THEN
         WRITE(1,*)' FROM RTPSV: NWN*2+1.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** COMPUTATION OF URX AND URZ ***
C
      CALL MTXPSV(OM,WN,LO,CMS,CMP,EE)
C
      IF(LO.EQ.NL)THEN
C        
        IF(LO.NE.LS)THEN
C
          CALL DDUPSV(OM,WN,ODEP,CMS,CMP,DD)
C
          E1(1,1)=EE(1,1)*DD(1,1)+EE(1,2)*DD(2,1)
          E1(1,2)=EE(1,1)*DD(1,2)+EE(1,2)*DD(2,2)
          E1(2,1)=EE(2,1)*DD(1,1)+EE(2,2)*DD(2,1)
          E1(2,2)=EE(2,1)*DD(1,2)+EE(2,2)*DD(2,2)
          URX(1,1)=E1(1,1)*CDX(K,1,LO,M)+E1(1,2)*CDX(K,2,LO,M)
          URX(2,1)=E1(2,1)*CDX(K,1,LO,M)+E1(2,2)*CDX(K,2,LO,M)
          URZ(1,1)=E1(1,1)*CDZ(K,1,LO,M)+E1(1,2)*CDZ(K,2,LO,M)
          URZ(2,1)=E1(2,1)*CDZ(K,1,LO,M)+E1(2,2)*CDZ(K,2,LO,M)
C
          E1(1,1)=EE(3,1)*DD(1,1)+EE(3,2)*DD(2,1)
          E1(1,2)=EE(3,1)*DD(1,2)+EE(3,2)*DD(2,2)
          E1(2,1)=EE(4,1)*DD(1,1)+EE(4,2)*DD(2,1)
          E1(2,2)=EE(4,1)*DD(1,2)+EE(4,2)*DD(2,2)
          URX(1,2)=E1(1,1)*CDX(K,1,LO,M)+E1(1,2)*CDX(K,2,LO,M)
          URX(2,2)=E1(2,1)*CDX(K,1,LO,M)+E1(2,2)*CDX(K,2,LO,M)
          URZ(1,2)=E1(1,1)*CDZ(K,1,LO,M)+E1(1,2)*CDZ(K,2,LO,M)
          URZ(2,2)=E1(2,1)*CDZ(K,1,LO,M)+E1(2,2)*CDZ(K,2,LO,M)
C
        ELSE
C
          IF(ODEP.GE.SDEP)THEN
C
            CALL DDUPSV(OM,WN,ODEP-SDEP,CMS,CMP,DD)
C
            E1(1,1)=EE(1,1)*DD(1,1)+EE(1,2)*DD(2,1)
            E1(1,2)=EE(1,1)*DD(1,2)+EE(1,2)*DD(2,2)
            E1(2,1)=EE(2,1)*DD(1,1)+EE(2,2)*DD(2,1)
            E1(2,2)=EE(2,1)*DD(1,2)+EE(2,2)*DD(2,2)
            URX(1,1)=E1(1,1)*CDSDX(K,1,M)+E1(1,2)*CDSDX(K,2,M)
            URX(2,1)=E1(2,1)*CDSDX(K,1,M)+E1(2,2)*CDSDX(K,2,M)
            URZ(1,1)=E1(1,1)*CDSDZ(K,1,M)+E1(1,2)*CDSDZ(K,2,M)
            URZ(2,1)=E1(2,1)*CDSDZ(K,1,M)+E1(2,2)*CDSDZ(K,2,M)
C
            E1(1,1)=EE(3,1)*DD(1,1)+EE(3,2)*DD(2,1)
            E1(1,2)=EE(3,1)*DD(1,2)+EE(3,2)*DD(2,2)
            E1(2,1)=EE(4,1)*DD(1,1)+EE(4,2)*DD(2,1)
            E1(2,2)=EE(4,1)*DD(1,2)+EE(4,2)*DD(2,2)
            URX(1,2)=E1(1,1)*CDSDX(K,1,M)+E1(1,2)*CDSDX(K,2,M)
            URX(2,2)=E1(2,1)*CDSDX(K,1,M)+E1(2,2)*CDSDX(K,2,M)
            URZ(1,2)=E1(1,1)*CDSDZ(K,1,M)+E1(1,2)*CDSDZ(K,2,M)
            URZ(2,2)=E1(2,1)*CDSDZ(K,1,M)+E1(2,2)*CDSDZ(K,2,M)
C
          ELSE
C
            CALL DDUPSV(OM,WN,ODEP,CMS,CMP,DD)
            CALL DDUPSV(OM,WN,SDEP-ODEP,CMS,CMP,DU)
C
            E1(1,1)=EE(1,1)*DD(1,1)+EE(1,2)*DD(2,1)
            E1(1,2)=EE(1,1)*DD(1,2)+EE(1,2)*DD(2,2)
            E1(2,1)=EE(2,1)*DD(1,1)+EE(2,2)*DD(2,1)
            E1(2,2)=EE(2,1)*DD(1,2)+EE(2,2)*DD(2,2)
            E2(1,1)=EE(1,3)*DU(1,1)+EE(1,4)*DU(2,1)
            E2(1,2)=EE(1,3)*DU(1,2)+EE(1,4)*DU(2,2)
            E2(2,1)=EE(2,3)*DU(1,1)+EE(2,4)*DU(2,1)
            E2(2,2)=EE(2,3)*DU(1,2)+EE(2,4)*DU(2,2)
C
            URX(1,1)=E1(1,1)*CDSUX(K,1,M)+E1(1,2)*CDSUX(K,2,M)
     *              +E2(1,1)*CUSUX(K,1,M)+E2(1,2)*CUSUX(K,2,M)
            URX(2,1)=E1(2,1)*CDSUX(K,1,M)+E1(2,2)*CDSUX(K,2,M)
     *              +E2(2,1)*CUSUX(K,1,M)+E2(2,2)*CUSUX(K,2,M)
            URZ(1,1)=E1(1,1)*CDSUZ(K,1,M)+E1(1,2)*CDSUZ(K,2,M)
     *              +E2(1,1)*CUSUZ(K,1,M)+E2(1,2)*CUSUZ(K,2,M)
            URZ(2,1)=E1(2,1)*CDSUZ(K,1,M)+E1(2,2)*CDSUZ(K,2,M)
     *              +E2(2,1)*CUSUZ(K,1,M)+E2(2,2)*CUSUZ(K,2,M)
C
            E1(1,1)=EE(3,1)*DD(1,1)+EE(3,2)*DD(2,1)
            E1(1,2)=EE(3,1)*DD(1,2)+EE(3,2)*DD(2,2)
            E1(2,1)=EE(4,1)*DD(1,1)+EE(4,2)*DD(2,1)
            E1(2,2)=EE(4,1)*DD(1,2)+EE(4,2)*DD(2,2)
            E2(1,1)=EE(3,3)*DU(1,1)+EE(3,4)*DU(2,1)
            E2(1,2)=EE(3,3)*DU(1,2)+EE(3,4)*DU(2,2)
            E2(2,1)=EE(4,3)*DU(1,1)+EE(4,4)*DU(2,1)
            E2(2,2)=EE(4,3)*DU(1,2)+EE(4,4)*DU(2,2)
C
            URX(1,2)=E1(1,1)*CDSUX(K,1,M)+E1(1,2)*CDSUX(K,2,M)
     *              +E2(1,1)*CUSUX(K,1,M)+E2(1,2)*CUSUX(K,2,M)
            URX(2,2)=E1(2,1)*CDSUX(K,1,M)+E1(2,2)*CDSUX(K,2,M)
     *              +E2(2,1)*CUSUX(K,1,M)+E2(2,2)*CUSUX(K,2,M)
            URZ(1,2)=E1(1,1)*CDSUZ(K,1,M)+E1(1,2)*CDSUZ(K,2,M)
     *              +E2(1,1)*CUSUZ(K,1,M)+E2(1,2)*CUSUZ(K,2,M)
            URZ(2,2)=E1(2,1)*CDSUZ(K,1,M)+E1(2,2)*CDSUZ(K,2,M)
     *              +E2(2,1)*CUSUZ(K,1,M)+E2(2,2)*CUSUZ(K,2,M)
C
          END IF
C
        END IF
C
      ELSE
C        
        IF(LO.NE.LS)THEN
C
            CALL DDUPSV(OM,WN,ODEP,CMS,CMP,DD)
            CALL DDUPSV(OM,WN,THK(LO)-ODEP,CMS,CMP,DU)
C
            E1(1,1)=EE(1,1)*DD(1,1)+EE(1,2)*DD(2,1)
            E1(1,2)=EE(1,1)*DD(1,2)+EE(1,2)*DD(2,2)
            E1(2,1)=EE(2,1)*DD(1,1)+EE(2,2)*DD(2,1)
            E1(2,2)=EE(2,1)*DD(1,2)+EE(2,2)*DD(2,2)
            E2(1,1)=EE(1,3)*DU(1,1)+EE(1,4)*DU(2,1)
            E2(1,2)=EE(1,3)*DU(1,2)+EE(1,4)*DU(2,2)
            E2(2,1)=EE(2,3)*DU(1,1)+EE(2,4)*DU(2,1)
            E2(2,2)=EE(2,3)*DU(1,2)+EE(2,4)*DU(2,2)
C
            URX(1,1)=E1(1,1)*CDX(K,1,LO,M)+E1(1,2)*CDX(K,2,LO,M)
     *              +E2(1,1)*CUX(K,1,LO,M)+E2(1,2)*CUX(K,2,LO,M)
            URX(2,1)=E1(2,1)*CDX(K,1,LO,M)+E1(2,2)*CDX(K,2,LO,M)
     *              +E2(2,1)*CUX(K,1,LO,M)+E2(2,2)*CUX(K,2,LO,M)
            URZ(1,1)=E1(1,1)*CDZ(K,1,LO,M)+E1(1,2)*CDZ(K,2,LO,M)
     *              +E2(1,1)*CUZ(K,1,LO,M)+E2(1,2)*CUZ(K,2,LO,M)
            URZ(2,1)=E1(2,1)*CDZ(K,1,LO,M)+E1(2,2)*CDZ(K,2,LO,M)
     *              +E2(2,1)*CUZ(K,1,LO,M)+E2(2,2)*CUZ(K,2,LO,M)
C
            E1(1,1)=EE(3,1)*DD(1,1)+EE(3,2)*DD(2,1)
            E1(1,2)=EE(3,1)*DD(1,2)+EE(3,2)*DD(2,2)
            E1(2,1)=EE(4,1)*DD(1,1)+EE(4,2)*DD(2,1)
            E1(2,2)=EE(4,1)*DD(1,2)+EE(4,2)*DD(2,2)
            E2(1,1)=EE(3,3)*DU(1,1)+EE(3,4)*DU(2,1)
            E2(1,2)=EE(3,3)*DU(1,2)+EE(3,4)*DU(2,2)
            E2(2,1)=EE(4,3)*DU(1,1)+EE(4,4)*DU(2,1)
            E2(2,2)=EE(4,3)*DU(1,2)+EE(4,4)*DU(2,2)
C
            URX(1,2)=E1(1,1)*CDX(K,1,LO,M)+E1(1,2)*CDX(K,2,LO,M)
     *              +E2(1,1)*CUX(K,1,LO,M)+E2(1,2)*CUX(K,2,LO,M)
            URX(2,2)=E1(2,1)*CDX(K,1,LO,M)+E1(2,2)*CDX(K,2,LO,M)
     *              +E2(2,1)*CUX(K,1,LO,M)+E2(2,2)*CUX(K,2,LO,M)
            URZ(1,2)=E1(1,1)*CDZ(K,1,LO,M)+E1(1,2)*CDZ(K,2,LO,M)
     *              +E2(1,1)*CUZ(K,1,LO,M)+E2(1,2)*CUZ(K,2,LO,M)
            URZ(2,2)=E1(2,1)*CDZ(K,1,LO,M)+E1(2,2)*CDZ(K,2,LO,M)
     *              +E2(2,1)*CUZ(K,1,LO,M)+E2(2,2)*CUZ(K,2,LO,M)
C
        ELSE
C
          IF(ODEP.GE.SDEP)THEN
C
            CALL DDUPSV(OM,WN,ODEP-SDEP,CMS,CMP,DD)
            CALL DDUPSV(OM,WN,THK(LO)-ODEP,CMS,CMP,DU)
C
            E1(1,1)=EE(1,1)*DD(1,1)+EE(1,2)*DD(2,1)
            E1(1,2)=EE(1,1)*DD(1,2)+EE(1,2)*DD(2,2)
            E1(2,1)=EE(2,1)*DD(1,1)+EE(2,2)*DD(2,1)
            E1(2,2)=EE(2,1)*DD(1,2)+EE(2,2)*DD(2,2)
            E2(1,1)=EE(1,3)*DU(1,1)+EE(1,4)*DU(2,1)
            E2(1,2)=EE(1,3)*DU(1,2)+EE(1,4)*DU(2,2)
            E2(2,1)=EE(2,3)*DU(1,1)+EE(2,4)*DU(2,1)
            E2(2,2)=EE(2,3)*DU(1,2)+EE(2,4)*DU(2,2)
C
            URX(1,1)=E1(1,1)*CDSDX(K,1,M)+E1(1,2)*CDSDX(K,2,M)
     *              +E2(1,1)*CUSDX(K,1,M)+E2(1,2)*CUSDX(K,2,M)
            URX(2,1)=E1(2,1)*CDSDX(K,1,M)+E1(2,2)*CDSDX(K,2,M)
     *              +E2(2,1)*CUSDX(K,1,M)+E2(2,2)*CUSDX(K,2,M)
            URZ(1,1)=E1(1,1)*CDSDZ(K,1,M)+E1(1,2)*CDSDZ(K,2,M)
     *              +E2(1,1)*CUSDZ(K,1,M)+E2(1,2)*CUSDZ(K,2,M)
            URZ(2,1)=E1(2,1)*CDSDZ(K,1,M)+E1(2,2)*CDSDZ(K,2,M)
     *              +E2(2,1)*CUSDZ(K,1,M)+E2(2,2)*CUSDZ(K,2,M)
C
            E1(1,1)=EE(3,1)*DD(1,1)+EE(3,2)*DD(2,1)
            E1(1,2)=EE(3,1)*DD(1,2)+EE(3,2)*DD(2,2)
            E1(2,1)=EE(4,1)*DD(1,1)+EE(4,2)*DD(2,1)
            E1(2,2)=EE(4,1)*DD(1,2)+EE(4,2)*DD(2,2)
            E2(1,1)=EE(3,3)*DU(1,1)+EE(3,4)*DU(2,1)
            E2(1,2)=EE(3,3)*DU(1,2)+EE(3,4)*DU(2,2)
            E2(2,1)=EE(4,3)*DU(1,1)+EE(4,4)*DU(2,1)
            E2(2,2)=EE(4,3)*DU(1,2)+EE(4,4)*DU(2,2)
C
            URX(1,2)=E1(1,1)*CDSDX(K,1,M)+E1(1,2)*CDSDX(K,2,M)
     *              +E2(1,1)*CUSDX(K,1,M)+E2(1,2)*CUSDX(K,2,M)
            URX(2,2)=E1(2,1)*CDSDX(K,1,M)+E1(2,2)*CDSDX(K,2,M)
     *              +E2(2,1)*CUSDX(K,1,M)+E2(2,2)*CUSDX(K,2,M)
            URZ(1,2)=E1(1,1)*CDSDZ(K,1,M)+E1(1,2)*CDSDZ(K,2,M)
     *              +E2(1,1)*CUSDZ(K,1,M)+E2(1,2)*CUSDZ(K,2,M)
            URZ(2,2)=E1(2,1)*CDSDZ(K,1,M)+E1(2,2)*CDSDZ(K,2,M)
     *              +E2(2,1)*CUSDZ(K,1,M)+E2(2,2)*CUSDZ(K,2,M)
C
          ELSE
C
            CALL DDUPSV(OM,WN,ODEP,CMS,CMP,DD)
            CALL DDUPSV(OM,WN,SDEP-ODEP,CMS,CMP,DU)
C
            E1(1,1)=EE(1,1)*DD(1,1)+EE(1,2)*DD(2,1)
            E1(1,2)=EE(1,1)*DD(1,2)+EE(1,2)*DD(2,2)
            E1(2,1)=EE(2,1)*DD(1,1)+EE(2,2)*DD(2,1)
            E1(2,2)=EE(2,1)*DD(1,2)+EE(2,2)*DD(2,2)
            E2(1,1)=EE(1,3)*DU(1,1)+EE(1,4)*DU(2,1)
            E2(1,2)=EE(1,3)*DU(1,2)+EE(1,4)*DU(2,2)
            E2(2,1)=EE(2,3)*DU(1,1)+EE(2,4)*DU(2,1)
            E2(2,2)=EE(2,3)*DU(1,2)+EE(2,4)*DU(2,2)
C
            URX(1,1)=E1(1,1)*CDSUX(K,1,M)+E1(1,2)*CDSUX(K,2,M)
     *              +E2(1,1)*CUSUX(K,1,M)+E2(1,2)*CUSUX(K,2,M)
            URX(2,1)=E1(2,1)*CDSUX(K,1,M)+E1(2,2)*CDSUX(K,2,M)
     *              +E2(2,1)*CUSUX(K,1,M)+E2(2,2)*CUSUX(K,2,M)
            URZ(1,1)=E1(1,1)*CDSUZ(K,1,M)+E1(1,2)*CDSUZ(K,2,M)
     *              +E2(1,1)*CUSUZ(K,1,M)+E2(1,2)*CUSUZ(K,2,M)
            URZ(2,1)=E1(2,1)*CDSUZ(K,1,M)+E1(2,2)*CDSUZ(K,2,M)
     *              +E2(2,1)*CUSUZ(K,1,M)+E2(2,2)*CUSUZ(K,2,M)
C
            E1(1,1)=EE(3,1)*DD(1,1)+EE(3,2)*DD(2,1)
            E1(1,2)=EE(3,1)*DD(1,2)+EE(3,2)*DD(2,2)
            E1(2,1)=EE(4,1)*DD(1,1)+EE(4,2)*DD(2,1)
            E1(2,2)=EE(4,1)*DD(1,2)+EE(4,2)*DD(2,2)
            E2(1,1)=EE(3,3)*DU(1,1)+EE(3,4)*DU(2,1)
            E2(1,2)=EE(3,3)*DU(1,2)+EE(3,4)*DU(2,2)
            E2(2,1)=EE(4,3)*DU(1,1)+EE(4,4)*DU(2,1)
            E2(2,2)=EE(4,3)*DU(1,2)+EE(4,4)*DU(2,2)
C
            URX(1,2)=E1(1,1)*CDSUX(K,1,M)+E1(1,2)*CDSUX(K,2,M)
     *              +E2(1,1)*CUSUX(K,1,M)+E2(1,2)*CUSUX(K,2,M)
            URX(2,2)=E1(2,1)*CDSUX(K,1,M)+E1(2,2)*CDSUX(K,2,M)
     *              +E2(2,1)*CUSUX(K,1,M)+E2(2,2)*CUSUX(K,2,M)
            URZ(1,2)=E1(1,1)*CDSUZ(K,1,M)+E1(1,2)*CDSUZ(K,2,M)
     *              +E2(1,1)*CUSUZ(K,1,M)+E2(1,2)*CUSUZ(K,2,M)
            URZ(2,2)=E1(2,1)*CDSUZ(K,1,M)+E1(2,2)*CDSUZ(K,2,M)
     *              +E2(2,1)*CUSUZ(K,1,M)+E2(2,2)*CUSUZ(K,2,M)
C
          END IF
C
        END IF
C
      END IF
C
      RETURN
      END
C
C
C *** THE DIRECT TRACTION GREEN FUNCTION ***
C
      SUBROUTINE DASYMT(DPP,RX,RY,XM,YM,ZM)
C
      COMPLEX DPP(3,3),VP,VS,A,B,VP2,VS2,SM,RM
     *    ,QXS(0:2),QZS(0:2),VXS(0:2),WXS(0:2),WZS(0:2)
     *    ,QX(0:3),QY(0:3),QZ(0:3),VX(0:3),VY(0:3)
     *    ,WX(0:3),WY(0:3),WZ(0:3),UX(3,3),UY(3,3),UZ(3,3)
      COMMON /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /DPSO /DEP1,DEP2,SDP,ODP /SOLY/LS,SDEP,LO,ODEP
C
C *** CHECK OF DIMENSION ***
C
      NC=20
      IF(NL.GE.NC)THEN
        WRITE(1,*)' FROM ASYMT:NL>NC !!!!!!!!!!'
        WRITE(1,*)' NL,NC=',NL,NC
        STOP
      END IF
C
C *** GREEN FUNCTION ***
C
      VS2= VS(LO)*VS(LO)
      SM = DNS(LO)*VS2
      VP2= VP(LO)*VP(LO)
      RM = DNS(LO)*VP2-2.0*SM
C
      RR=SQRT(RX*RX+RY*RY)
C
      CALL DCASYM(LS,NL)
      CALL AINTG(RR,LS,NL,QXS,QZS,VXS,WXS,WZS)
C
      IF(RR.EQ.0.0)THEN
        CR=0.0
        SR=0.0
        C2=0.0
        S2=0.0
        CS=0.0
        CX=0.0
        SY=0.0
        CY=0.0
      ELSE
        CR=RX/RR
        SR=RY/RR
        C2=CR*CR
        S2=SR*SR
        CS=CR*SR
        CX=S2/RR
        SY=C2/RR
        CY=-CS/RR
      END IF
      SX=CY
C
      A=QXS(0)
      QX(0)=A*CR
      QY(0)=A*SR
      B=QXS(1)
      QX(1)=B*C2+A*CX
      QY(1)=B*CS+A*SX
      QX(2)=B*CS+A*CY
      QY(2)=B*S2+A*SY
      B=QXS(2)
      QX(3)= B*CR
      QY(3)= B*SR
C
      QZ(0)=-QZS(0)
      B=QZS(1)
      QZ(1)=-B*CR
      QZ(2)=-B*SR
      QZ(3)=-QZS(2)
C
      A=VXS(0)
      VX(0)=-A*SR
      VY(0)= A*CR
      B=VXS(1)
      VX(1)=-(B*CS+A*SX)
      VY(1)=  B*C2+A*CX
      VX(2)=-(B*S2+A*SY)
      VY(2)=  B*CS+A*CY
      B=VXS(2)
      VX(3)=-B*SR
      VY(3)= B*CR
C
      A=WXS(0)
      WX(0)=-A*CR
      WY(0)=-A*SR
      B=WXS(1)
      WX(1)=-(B*C2+A*CX)
      WY(1)=-(B*CS+A*SX)
      WX(2)=-(B*CS+A*CY)
      WY(2)=-(B*S2+A*SY)
      B=WXS(2)
      WX(3)=-B*CR
      WY(3)=-B*SR
C
      WZ(0)=-WZS(0)
      B=WZS(1)
      WZ(1)=-B*CR
      WZ(2)=-B*SR
      WZ(3)=-WZS(2)
C
      UX(1,1)=QX(1)*CR+QX(0)*CX-VX(1)*SR-VX(0)*SX
      UX(1,2)=QX(2)*CR+QX(0)*CY-VX(2)*SR-VX(0)*SY
      UX(1,3)=QX(3)*CR-VX(3)*SR
      UY(1,1)=QY(1)*CR+QY(0)*CX-VY(1)*SR-VY(0)*SX
      UY(1,2)=QY(2)*CR+QY(0)*CY-VY(2)*SR-VY(0)*SY
      UY(1,3)=QY(3)*CR-VY(3)*SR
      UZ(1,1)=QZ(1)*CR+QZ(0)*CX
      UZ(1,2)=QZ(2)*CR+QZ(0)*CY
      UZ(1,3)=QZ(3)*CR
C
      UX(2,1)=QX(1)*SR+QX(0)*SX+VX(1)*CR+VX(0)*CX
      UX(2,2)=QX(2)*SR+QX(0)*SY+VX(2)*CR+VX(0)*CY
      UX(2,3)=QX(3)*SR+VX(3)*CR
      UY(2,1)=QY(1)*SR+QY(0)*SX+VY(1)*CR+VY(0)*CX
      UY(2,2)=QY(2)*SR+QY(0)*SY+VY(2)*CR+VY(0)*CY
      UY(2,3)=QY(3)*SR+VY(3)*CR
      UZ(2,1)=QZ(1)*SR+QZ(0)*SX
      UZ(2,2)=QZ(2)*SR+QZ(0)*SY
      UZ(2,3)=QZ(3)*SR
C
      UX(3,1)=WX(1)
      UX(3,2)=WX(2)
      UX(3,3)=WX(3)
      UY(3,1)=WY(1)
      UY(3,2)=WY(2)
      UY(3,3)=WY(3)
      UZ(3,1)=WZ(1)
      UZ(3,2)=WZ(2)
      UZ(3,3)=WZ(3)
C
      A=(UX(1,1)+UX(2,2)+UX(3,3))*RM
      B=SM*(2.0*UX(1,1)*XM+(UX(1,2)+UX(2,1))*YM+(UX(1,3)+UX(3,1))*ZM)
      DPP(1,1)=A*XM+B
      B=SM*((UX(2,1)+UX(1,2))*XM+2.0*UX(2,2)*YM+(UX(2,3)+UX(3,2))*ZM)
      DPP(2,1)=A*YM+B
      B=SM*((UX(3,1)+UX(1,3))*XM+(UX(3,2)+UX(2,3))*YM+2.0*UX(3,3)*ZM)
      DPP(3,1)=A*ZM+B
C
      A=(UY(1,1)+UY(2,2)+UY(3,3))*RM
      B=SM*(2.0*UY(1,1)*XM+(UY(1,2)+UY(2,1))*YM+(UY(1,3)+UY(3,1))*ZM)
      DPP(1,2)=A*XM+B
      B=SM*((UY(2,1)+UY(1,2))*XM+2.0*UY(2,2)*YM+(UY(2,3)+UY(3,2))*ZM)
      DPP(2,2)=A*YM+B
      B=SM*((UY(3,1)+UY(1,3))*XM+(UY(3,2)+UY(2,3))*YM+2.0*UY(3,3)*ZM)
      DPP(3,2)=A*ZM+B
C
      A=(UZ(1,1)+UZ(2,2)+UZ(3,3))*RM
      B=SM*(2.0*UZ(1,1)*XM+(UZ(1,2)+UZ(2,1))*YM+(UZ(1,3)+UZ(3,1))*ZM)
      DPP(1,3)=A*XM+B
      B=SM*((UZ(2,1)+UZ(1,2))*XM+2.0*UZ(2,2)*YM+(UZ(2,3)+UZ(3,2))*ZM)
      DPP(2,3)=A*YM+B
      B=SM*((UZ(3,1)+UZ(1,3))*XM+(UZ(3,2)+UZ(2,3))*YM+2.0*UZ(3,3)*ZM)
      DPP(3,3)=A*ZM+B
C
      RETURN
      END
C
C *** ASTMPTOTIC SOLUTION ***
C
      SUBROUTINE ASYM(LS,NL,WN,H1X,H2X
     *               ,V1X,V2X,V3X,V4X,V1Z,V2Z,V3Z,V4Z)
C
      COMPLEX SM1,SM2,SM3,X1,X2,X3,A,B
     *   ,H1T,H2T,H1D,H2D,H1R1,H2R1,H1R2,H2R2       
     *   ,CUPX,CUSX,CUP1X,CUS1X,CUP2X,CUS2X
     *   ,CDPX,CDSX,CDP1X,CDS1X,CDP2X,CDS2X
     *   ,CUPZ,CUSZ,CUP1Z,CUS1Z,CUP2Z,CUS2Z
     *   ,CDPZ,CDSZ,CDP1Z,CDS1Z,CDP2Z,CDS2Z
     *   ,CSD,CPD,CST,CPT,CSR1,CPR1,CSR2,CPR2
     *   ,V1X,V2X,V3X,V4X,V1Z,V2Z,V3Z,V4Z,H1X,H2X
      COMMON /ASYMP/SM1,X1,SM2,X2,SM3,X3
     *       /DPSO /DEP1,DEP2,SDP,ODP
     *      /HX  /H1T,H2T,H1D,H2D,H1R1,H2R1,H1R2,H2R2       
     *      /VUX /CUPX,CUSX,CUP1X,CUS1X,CUP2X,CUS2X
     *      /VDX /CDPX,CDSX,CDP1X,CDS1X,CDP2X,CDS2X
     *      /VUZ /CUPZ,CUSZ,CUP1Z,CUS1Z,CUP2Z,CUS2Z
     *      /VDZ /CDPZ,CDSZ,CDP1Z,CDS1Z,CDP2Z,CDS2Z
C
C *** DISP-STRESS VECTOR DUE TO Qx FOR ODP < DEP1 ***
C
      IF(ODP.GE.DEP1)GOTO 10
      IF(LS.EQ.1)GOTO 10
C
C   * UP-GOING WAVE DUE TO TRANSMITTED WAVE *
C
      WHZ=WN*(SDP-ODP)
      WHZ1=WN*(SDP-DEP1)
      WZ1Z=WN*(DEP1-ODP)
      EX=EXP(-WHZ)
C
      CPT=EX*(CUP1X-WHZ1*CUP2X)
      CST=EX*(CUS1X-WZ1Z*CUP1X-WHZ1*CUS2X+WZ1Z*WHZ1*CUP2X)
C
      H1X=EX*H1T
      H2X=WN*EX*H2T
C
      A=X1-1.0
      B=X1-3.0
      V1X=CPT+CST
      V2X=A*CPT-CST
      V3X=WN*SM1*(-B*CPT+2.0*CST)
      V4X=WN*SM1*( A*CPT-2.0*CST)
C
C   * DISP-STRESS VECTOR DUE TO Qz *
C
      CPT=EX*(CUP1Z-WHZ1*CUP2Z)
      CST=EX*(CUS1Z-WZ1Z*CUP1Z-WHZ1*CUS2Z+WZ1Z*WHZ1*CUP2Z)
C
      V1Z=CPT+CST
      V2Z=A*CPT-CST
      V3Z=WN*SM1*(-B*CPT+2.0*CST)
      V4Z=WN*SM1*( A*CPT-2.0*CST)
C
      GOTO 50
C
C *** DISP-STRESS VECTOR DUE TO Qx FOR DEP1 < (OR =) ODP < SDP ***
C
   10 IF(ODP.GE.SDP)GOTO 20
C
C   * UP-GOING WAVE DUE TO DIRECT WAVE *
C
      WHZ=WN*(SDP-ODP)
      EXD=EXP(-WHZ)
C
      CPD=EXD*CUPX
      CSD=EXD*(CUSX-WHZ*CUPX)
C
C   * DOWN-GOING WAVE DUE TO REFLECT WAVE FROM UPPER BOUNDARY *
C
      WHZ1=WN*(SDP-DEP1)
      WZZ1=WN*(ODP-DEP1)
      EXR1=EXP(-WHZ1-WZZ1)
C
      CPR1=EXR1*(CDP1X-WHZ1*CDP2X)
      CSR1=EXR1*(CDS1X-WHZ1*CDS2X-WZZ1*CDP1X+WZZ1*WHZ1*CDP2X)
C
C   * UP-GOING WAVE DUE TO REFLECT WAVE FROM LOWER BOUNDARY *
C
      IF(LS.EQ.NL)THEN
        CPR2=(0.0,0.0)
        CSR2=(0.0,0.0)
      ELSE
        WZ2H=WN*(DEP2-SDP)
        WZ2Z=WN*(DEP2-ODP)
        EXR2=EXP(-WZ2H-WZ2Z)
        CPR2=EXR2*(CUP1X-WZ2H*CUP2X)
        CSR2=EXR2*(CUS1X-WZ2H*CUS2X-WZ2Z*CUP1X+WZ2Z*WZ2H*CUP2X)
      END IF
C
C   * DISP-STRESS VECTORS *
C
      H1X=H1D*EXD+H1R1*EXR1+H1R2*EXR2
      H2X=WN*(H2D*EXD+H2R1*EXR1+H2R2*EXR2)
C
      A=X2-1.0
      B=X2-3.0
      V1X=CPR1+CSR1+CPD+CSD+CPR2+CSR2
      V2X=-A*CPR1+CSR1+A*(CPD+CPR2)-CSD-CSR2
      V3X=WN*SM2*(B*CPR1-2.0*CSR1-B*(CPD+CPR2)+2.0*(CSD+CSR2))
      V4X=WN*SM2*(A*CPR1-2.0*CSR1+A*(CPD+CPR2)-2.0*(CSD+CSR2))
C
C   * DISP-STRESS VECTOR DUE TO Qz *
C
      CPD=EXD*CUPZ
      CSD=EXD*(CUSZ-WHZ*CUPZ)
C
      CPR1=EXR1*(CDP1Z-WHZ1*CDP2Z)
      CSR1=EXR1*(CDS1Z-WHZ1*CDS2Z-WZZ1*CDP1Z+WZZ1*WHZ1*CDP2Z)
C
      IF(LS.EQ.NL)THEN
        CPR2=(0.0,0.0)
        CSR2=(0.0,0.0)
      ELSE
        CPR2=EXR2*(CUP1Z-WZ2H*CUP2Z)
        CSR2=EXR2*(CUS1Z-WZ2H*CUS2Z-WZ2Z*CUP1Z+WZ2Z*WZ2H*CUP2Z)
      END IF
C
      V1Z=CPR1+CSR1+CPD+CSD+CPR2+CSR2
      V2Z=-A*CPR1+CSR1+A*(CPD+CPR2)-CSD-CSR2
      V3Z=WN*SM2*(B*CPR1-2.0*CSR1-B*(CPD+CPR2)+2.0*(CSD+CSR2))
      V4Z=WN*SM2*(A*CPR1-2.0*CSR1+A*(CPD+CPR2)-2.0*(CSD+CSR2))
C
      GOTO 50
C
C *** DISP-STRESS VECTOR DUE TO Qx FOR SDP < (OR =) ODP < DEP2 ***
C
   20 IF((LS.NE.NL).AND.(ODP.GE.DEP2))GOTO 30
C
C   * DOWN-GOING WAVE DUE TO DIRECT WAVE *
C
      WZH=WN*(ODP-SDP)
      EXD=EXP(-WZH)
C
      CPD=EXD*CDPX
      CSD=EXD*(CDSX-WZH*CDPX)
C
C   * UP-GOING WAVE DUE TO REFLECT WAVE FROM LOWER BOUNDARY *
C
      IF(LS.EQ.NL)THEN
        CPR2=(0.0,0.0)
        CSR2=(0.0,0.0)
      ELSE
        WZ2H=WN*(DEP2-SDP)
        WZ2Z=WN*(DEP2-ODP)
        EXR2=EXP(-WZ2H-WZ2Z)
        CPR2=EXR2*(CUP1X-WZ2H*CUP2X)
        CSR2=EXR2*(CUS1X-WZ2H*CUS2X-WZ2Z*CUP1X+WZ2Z*WZ2H*CUP2X)
      END IF
C
C   * DOWN-GOING WAVE DUE TO REFLECT WAVE FROM UPPER BOUNDARY *
C
      WHZ1=WN*(SDP-DEP1)
      WZZ1=WN*(ODP-DEP1)
      EXR1=EXP(-WHZ1-WZZ1)
C
      CPR1=EXR1*(CDP1X-WHZ1*CDP2X)
      CSR1=EXR1*(CDS1X-WHZ1*CDS2X-WZZ1*CDP1X+WZZ1*WHZ1*CDP2X)
C
C   * DISP-STRESS VECTORS *
C
      H1X=H1D*EXD+H1R1*EXR1+H1R2*EXR2
      H2X=WN*(-H2D*EXD+H2R1*EXR1+H2R2*EXR2)
C
      A=X2-1.0
      B=X2-3.0
      V1X=CPD+CSD+CPR1+CSR1+CPR2+CSR2
      V2X=-A*(CPD+CPR1)+CSD+CSR1+A*CPR2-CSR2
      V3X=WN*SM2*(B*(CPD+CPR1)-2.0*(CSD+CSR1)-B*CPR2+2.0*CSR2)
      V4X=WN*SM2*(A*(CPD+CPR1)-2.0*(CSD+CSR1)+A*CPR2-2.0*CSR2)
C
C   * DISP-STRESS VECTOR DUE TO Qz *
C
      CPD=EXD*CDPZ
      CSD=EXD*(CDSZ-WZH*CDPZ)
C
      IF(LS.EQ.NL)THEN
        CPR2=(0.0,0.0)
        CSR2=(0.0,0.0)
      ELSE
        CPD=EXD*CDPZ
        CSD=EXD*(CDSZ-WZH*CDPZ)
        CPR2=EXR2*(CUP1Z-WZ2H*CUP2Z)
        CSR2=EXR2*(CUS1Z-WZ2H*CUS2Z-WZ2Z*CUP1Z+WZ2Z*WZ2H*CUP2Z)
      END IF
C
      CPR1=EXR1*(CDP1Z-WHZ1*CDP2Z)
      CSR1=EXR1*(CDS1Z-WHZ1*CDS2Z-WZZ1*CDP1Z+WZZ1*WHZ1*CDP2Z)
C
      V1Z=CPD+CSD+CPR1+CSR1+CPR2+CSR2
      V2Z=-A*(CPD+CPR1)+CSD+CSR1+A*CPR2-CSR2
      V3Z=WN*SM2*(B*(CPD+CPR1)-2.0*(CSD+CSR1)-B*CPR2+2.0*CSR2)
      V4Z=WN*SM2*(A*(CPD+CPR1)-2.0*(CSD+CSR1)+A*CPR2-2.0*CSR2)
C
      GOTO 50
C
C *** DISP-STRESS VECTOR DUE TO Qx FOR DEP2 < (OR =) ODP ***
C
   30 WZH=WN*(ODP-SDP)
      WZ2H=WN*(DEP2-SDP)
      WZZ2=WN*(ODP-DEP2)
      EX=EXP(-WZH)
C
      CPT=EX*(CDP1X-WZ2H*CDP2X)
      CST=EX*(CDS1X-WZZ2*CDP1X-WZ2H*CDS2X+WZZ2*WZ2H*CDP2X)
C
      H1X=EX*H1T
      H2X=WN*EX*H2T
C
      A=X3-1.0
      B=X3-3.0
      V1X=CPT+CST
      V2X=-A*CPT+CST
      V3X=WN*SM3*(B*CPT-2.0*CST)
      V4X=WN*SM3*(A*CPT-2.0*CST)
C
C   * DISP-STRESS VECTOR DUE TO Qz *
C
      CPT=EX*(CDP1Z-WZ2H*CDP2Z)
      CST=EX*(CDS1Z-WZZ2*CDP1Z-WZ2H*CDS2Z+WZZ2*WZ2H*CDP2Z)
C
      V1Z=CPT+CST
      V2Z=-A*CPT+CST
      V3Z=WN*SM3*(B*CPT-2.0*CST)
      V4Z=WN*SM3*(A*CPT-2.0*CST)
C
   50 RETURN
      END
C
C
C *** COEFFICIENTS FOR  ASYMPTOTIC SOLUTIONS FOR DIRECT WAVES ***
C
      SUBROUTINE DCASYM(LS,NL)
C
      COMPLEX SM1,X1,SM2,X2,SM3,X3
     *   ,H1T,H2T,H1D,H2D,H1R1,H2R1,H1R2,H2R2       
     *   ,CUPX,CUSX,CUP1X,CUS1X,CUP2X,CUS2X
     *   ,CDPX,CDSX,CDP1X,CDS1X,CDP2X,CDS2X
     *   ,CUPZ,CUSZ,CUP1Z,CUS1Z,CUP2Z,CUS2Z
     *   ,CDPZ,CDSZ,CDP1Z,CDS1Z,CDP2Z,CDS2Z
      COMMON/ASYMP/SM1,X1,SM2,X2,SM3,X3
     *      /DPSO /DEP1,DEP2,SDP,ODP
     *      /HX  /H1T,H2T,H1D,H2D,H1R1,H2R1,H1R2,H2R2       
     *      /VUX /CUPX,CUSX,CUP1X,CUS1X,CUP2X,CUS2X
     *      /VDX /CDPX,CDSX,CDP1X,CDS1X,CDP2X,CDS2X
     *      /VUZ /CUPZ,CUSZ,CUP1Z,CUS1Z,CUP2Z,CUS2Z
     *      /VDZ /CDPZ,CDSZ,CDP1Z,CDS1Z,CDP2Z,CDS2Z
C
C *** ODP < SDP *** 
C
      IF(ODP.GE.SDP) GOTO 20
C
C  ** QX **
C
C   * SH *
C
      H2D=0.07957747155
      H1D=H2D/SM2
      H1R1=(0.0,0.0)
      H2R1=(0.0,0.0)
      H1R2=(0.0,0.0)
      H2R2=(0.0,0.0)
C
C   * P-SV (UP-GOING DIRECT) *
C
      CUPX=0.25/(3.141592654*SM2*(X2+1.0))
      CUSX=CUPX*(X2-1.0)
C
C   * P-SV (DOWN-GOING REFLECTED FROM UPPER BOUNDARY) *
C
      CDP1X=(0.0,0.0)
      CDS1X=(0.0,0.0)
      CDP2X=(0.0,0.0)
      CDS2X=(0.0,0.0)
C
C   * P-SV (UP-GOING REFLECTED FROM LOWER BOUNDARY) *
C
      IF(LS.EQ.NL)GOTO 15
C
      CUP1X=(0.0,0.0)
      CUS1X=(0.0,0.0)
      CUP2X=(0.0,0.0)
      CUS2X=(0.0,0.0)
C
C  ** QZ **
C
   15 CUSZ=0.25/(3.141592654*SM2*(X2+1.0))
      CUPZ=-CUSZ
C
      CDP1Z=(0.0,0.0)
      CDS1Z=(0.0,0.0)
      CDP2Z=(0.0,0.0)
      CDS2Z=(0.0,0.0)
C
      IF(LS.EQ.NL)GOTO 50
C
      CUP1Z=(0.0,0.0)
      CUS1Z=(0.0,0.0)
      CUP2Z=(0.0,0.0)
      CUS2Z=(0.0,0.0)
C
      GOTO 50
C
C *** SDP < (OR =) ODP ***
C
C  ** QX **
C
C   * SH *
C
 20   H2D=0.07957747155
      H1D=H2D/SM2
      H1R1=(0.0,0.0)
      H2R1=(0.0,0.0)
      H1R2=(0.0,0.0)
      H2R2=(0.0,0.0)
C
C   * P-SV (DOWN-GOING DIRECT) *
C
      CDPX=0.25/(3.141592654*SM2*(X2+1.0))
      CDSX=CDPX*(X2-1.0)
C
C   * P-SV (UP-GOING REFLECTED FROM LOWER BOUNDARY) *
C
      IF(LS.EQ.NL)GOTO 25
C
      CUP1X=(0.0,0.0)
      CUS1X=(0.0,0.0)
      CUP2X=(0.0,0.0)
      CUS2X=(0.0,0.0)
C
C   * P-SV (DOWN-GOING REFLECTED FROM UPPER BOUNDARY) *
C
   25 CDP1X=(0.0,0.0)
      CDS1X=(0.0,0.0)
      CDP2X=(0.0,0.0)
      CDS2X=(0.0,0.0)
C
C  ** QZ **
C
      CDPZ=0.25/(3.141592654*SM2*(X2+1.0))
      CDSZ=-CDPZ
C
      IF(LS.EQ.NL)GOTO 27
C
      CUP1Z=(0.0,0.0)
      CUS1Z=(0.0,0.0)
      CUP2Z=(0.0,0.0)
      CUS2Z=(0.0,0.0)
C
   27 CDP1Z=(0.0,0.0)
      CDS1Z=(0.0,0.0)
      CDP2Z=(0.0,0.0)
      CDS2Z=(0.0,0.0)
C
   50 RETURN
C
      END
C
C *** COEFFICIENTS FOR  ASYMPTOTIC SOLUTIONS ***
C
      SUBROUTINE CASYM(LS,NL)
C
      COMPLEX SM1,X1,SM2,X2,SM3,X3,BB(4,4),BB1(4,4),BB2(4,4)
     *   ,H1T,H2T,H1D,H2D,RH,H1R1,H2R1,H1R2,H2R2       
     *   ,CUPX,CUSX,CUP1X,CUS1X,CUP2X,CUS2X
     *   ,CDPX,CDSX,CDP1X,CDS1X,CDP2X,CDS2X
     *   ,CUPZ,CUSZ,CUP1Z,CUS1Z,CUP2Z,CUS2Z
     *   ,CDPZ,CDSZ,CDP1Z,CDS1Z,CDP2Z,CDS2Z
      COMMON/ASYMP/SM1,X1,SM2,X2,SM3,X3
     *      /DPSO /DEP1,DEP2,SDP,ODP
     *      /HX  /H1T,H2T,H1D,H2D,H1R1,H2R1,H1R2,H2R2       
     *      /VUX /CUPX,CUSX,CUP1X,CUS1X,CUP2X,CUS2X
     *      /VDX /CDPX,CDSX,CDP1X,CDS1X,CDP2X,CDS2X
     *      /VUZ /CUPZ,CUSZ,CUP1Z,CUS1Z,CUP2Z,CUS2Z
     *      /VDZ /CDPZ,CDSZ,CDP1Z,CDS1Z,CDP2Z,CDS2Z
C
C *** ODP < DEP1 ***
C
      IF(ODP.GE.DEP1) GOTO 10
      IF(LS.EQ.1) GOTO 10
C
C  ** QX **
C
C   * SH (TRANSMITTED) *
C
      H1T=0.15915494309/(SM1+SM2)
      H2T=SM1*H1T
C
C   * P-SV (TRANSMITTED) *
C
      CUPX=0.25/(3.141592654*SM2*(X2+1.0))
      CUSX=CUPX*(X2-1.0)
C
      CALL EINVE(SM1,SM2,X1,X2,BB)
C
      CUP1X=BB(3,3)*CUPX+BB(3,4)*CUSX
      CUS1X=BB(4,3)*CUPX+BB(4,4)*CUSX
      CUP2X=BB(3,4)*CUPX
      CUS2X=BB(4,4)*CUPX
C
C  ** QZ **
C
C   * P-SV (TRANSMITTED) *
C
      CUSZ=0.25/(3.141592654*SM2*(X2+1.0))
      CUPZ=-CUSZ
C
      CUP1Z=BB(3,3)*CUPZ+BB(3,4)*CUSZ
      CUS1Z=BB(4,3)*CUPZ+BB(4,4)*CUSZ
      CUP2Z=BB(3,4)*CUPZ
      CUS2Z=BB(4,4)*CUPZ
C
      GOTO 50
C
C *** DEP1 < (OR =) ODP < SDP ***
C
   10 IF(ODP.GE.SDP) GOTO 20
C
C  ** QX **
C
C   * SH *
C
      H2D=0.07957747155
      H1D=H2D/SM2
      RH=(SM2-SM1)/(SM2+SM1)
      IF(LS.EQ.1)RH=(1.0,0.0)
      H1R1= RH*H1D
      H2R1=-RH*H2D
      RH=(SM3-SM2)/(SM3+SM2)
      IF(LS.EQ.NL)RH=(0.0,0.0)
      H1R2=-RH*H1D
      H2R2=-RH*H2D
C
C   * P-SV (UP-GOING DIRECT) *
C
      CUPX=0.25/(3.141592654*SM2*(X2+1.0))
      CUSX=CUPX*(X2-1.0)
C
C   * P-SV (DOWN-GOING REFLECTED FROM UPPER BOUNDARY) *
C
      IF(LS.EQ.1)THEN
        BB1(1,3)=-(X2-2.0)
        BB1(1,4)=2.0
        BB1(2,3)=-0.5*(X2-1.0)*(X2-3.0)
        BB1(2,4)=X2-2.0
      ELSE 
        CALL EINVE(SM1,SM2,X1,X2,BB1)
      END IF
C
      CDP1X=BB1(1,3)*CUPX+BB1(1,4)*CUSX
      CDS1X=BB1(2,3)*CUPX+BB1(2,4)*CUSX
      CDP2X=BB1(1,4)*CUPX
      CDS2X=BB1(2,4)*CUPX
C
C   * P-SV (UP-GOING REFLECTED FROM LOWER BOUNDARY) *
C
      IF(LS.EQ.NL)GOTO 15
C
      CDPX=CUPX
      CDSX=CUSX
C
      CALL EINVE(SM2,SM3,X2,X3,BB2)
C
      CUP1X=BB2(3,1)*CDPX+BB2(3,2)*CDSX
      CUS1X=BB2(4,1)*CDPX+BB2(4,2)*CDSX
      CUP2X=BB2(3,2)*CDPX
      CUS2X=BB2(4,2)*CDPX
C
C  ** QZ **
C
   15 CUSZ=0.25/(3.141592654*SM2*(X2+1.0))
      CUPZ=-CUSZ
C
      CDP1Z=BB1(1,3)*CUPZ+BB1(1,4)*CUSZ
      CDS1Z=BB1(2,3)*CUPZ+BB1(2,4)*CUSZ
      CDP2Z=BB1(1,4)*CUPZ
      CDS2Z=BB1(2,4)*CUPZ
C
      IF(LS.EQ.NL)GOTO 50
C
      CDPZ=CUSZ
      CDSZ=-CDPZ
C
      CUP1Z=BB2(3,1)*CDPZ+BB2(3,2)*CDSZ
      CUS1Z=BB2(4,1)*CDPZ+BB2(4,2)*CDSZ
      CUP2Z=BB2(3,2)*CDPZ
      CUS2Z=BB2(4,2)*CDPZ
C
      GOTO 50
C
C *** SDP < (OR =) ODP < DEP2 ***
C
   20 IF((LS.NE.NL).AND.(ODP.GE.DEP2)) GOTO 30
C
C  ** QX **
C
C   * SH *
C
      H2D=0.07957747155
      H1D=H2D/SM2
      RH=(SM2-SM1)/(SM2+SM1)
      IF(LS.EQ.1)RH=(1.0,0.0)
      H1R1= RH*H1D
      H2R1=-RH*H2D
      RH=(SM3-SM2)/(SM3+SM2)
      IF(LS.EQ.NL)RH=(0.0,0.0)
      H1R2=-RH*H1D
      H2R2=-RH*H2D
C
C   * P-SV (DOWN-GOING DIRECT) *
C
      CDPX=0.25/(3.141592654*SM2*(X2+1.0))
      CDSX=CDPX*(X2-1.0)
C
C   * P-SV (UP-GOING REFLECTED FROM LOWER BOUNDARY) *
C
      IF(LS.EQ.NL)GOTO 25
C
      CALL EINVE(SM2,SM3,X2,X3,BB2)
C
      CUP1X=BB2(3,1)*CDPX+BB2(3,2)*CDSX
      CUS1X=BB2(4,1)*CDPX+BB2(4,2)*CDSX
      CUP2X=BB2(3,2)*CDPX
      CUS2X=BB2(4,2)*CDPX
C
C   * P-SV (DOWN-GOING REFLECTED FROM UPPER BOUNDARY) *
C
   25 CUPX=CDPX
      CUSX=CDSX
C
      IF(LS.EQ.1)THEN
        BB1(1,3)=-(X2-2.0)
        BB1(1,4)=2.0
        BB1(2,3)=-0.5*(X2-1.0)*(X2-3.0)
        BB1(2,4)=X2-2.0
      ELSE 
        CALL EINVE(SM1,SM2,X1,X2,BB1)
      END IF
C
      CDP1X=BB1(1,3)*CUPX+BB1(1,4)*CUSX
      CDS1X=BB1(2,3)*CUPX+BB1(2,4)*CUSX
      CDP2X=BB1(1,4)*CUPX
      CDS2X=BB1(2,4)*CUPX
C
C  ** QZ **
C
      CDPZ=0.25/(3.141592654*SM2*(X2+1.0))
      CDSZ=-CDPZ
C
      IF(LS.EQ.NL)GOTO 27
C
      CUP1Z=BB2(3,1)*CDPZ+BB2(3,2)*CDSZ
      CUS1Z=BB2(4,1)*CDPZ+BB2(4,2)*CDSZ
      CUP2Z=BB2(3,2)*CDPZ
      CUS2Z=BB2(4,2)*CDPZ
C
   27 CUPZ=-CDPZ
      CUSZ=-CDSZ
C
      CDP1Z=BB1(1,3)*CUPZ+BB1(1,4)*CUSZ
      CDS1Z=BB1(2,3)*CUPZ+BB1(2,4)*CUSZ
      CDP2Z=BB1(1,4)*CUPZ
      CDS2Z=BB1(2,4)*CUPZ
C
      GOTO 50
C
C *** SDP < DEP2 < (OR =) ODP ***
C
C  ** QX **
C
C   * SH (TRANSMITTED) *
C
   30 H1T=0.15915494309/(SM3+SM2)
      H2T=-SM3*H1T
C
C   * P-SV (TRANSMITTED) *
C
      CDPX=0.25/(3.141592654*SM2*(X2+1.0))
      CDSX=CDPX*(X2-1.0)
C
      CALL EINVE(SM2,SM3,X2,X3,BB)
C
      CDP1X=BB(1,1)*CDPX+BB(1,2)*CDSX
      CDS1X=BB(2,1)*CDPX+BB(2,2)*CDSX
      CDP2X=BB(1,2)*CDPX
      CDS2X=BB(2,2)*CDPX
C
C  ** QZ **
C
      CDPZ=0.25/(3.141592654*SM2*(X2+1.0))
      CDSZ=-CDPZ
C
      CALL EINVE(SM2,SM3,X2,X3,BB)
C
      CDP1Z=BB(1,1)*CDPZ+BB(1,2)*CDSZ
      CDS1Z=BB(2,1)*CDPZ+BB(2,2)*CDSZ
      CDP2Z=BB(1,2)*CDPZ
      CDS2Z=BB(2,2)*CDPZ
C
   50 RETURN
C
      END
C
C *** PRODUCT OF INV E(L+1) * E(L) ***
C
      SUBROUTINE EINVE(SM1,SM2,X1,X2,BB)
C
      COMPLEX BB(4,4),SM1,SM2,X1,X2,A,A2,B
C
      A=SM1/SM2
      A2=A*A
      B=0.5/(X1+A2*X2+A*(X1*X2+1.0))
C
      BB(1,1)=2.0*(X1+1.0)*A*(A+X1)
      BB(2,1)=(X1+1.0)*A*(X1*X2-3.0*X1+2.0-A*(X1*X2-3.0*X2+2.0))
      BB(3,1)=2.0*(X1-2.0)*(1.0-A)*(1.0+A*X2)
      BB(4,1)=A*(X2-1.0)*(X1*X1-3.0*X1+4.0)
     *         -(X1-1.0)*(4.0+A2*(X1-3.0)*X2)
C
      BB(1,2)=(0.0,0.0)
      BB(2,2)=2.0*(X1+1.0)*A*(1.0+A*X2)
      BB(3,2)=4.0*(A-1.0)*(1.0+A*X2)
      BB(4,2)=-BB(3,1)
C
      BB(1,3)=2.0*(X2-2.0)*(A-1.0)*(A+X1)
      BB(2,3)=A*(X1-1.0)*(X2*X2-3.0*X2+4.0)
     *         -(X2-1.0)*(4.0*A2+(X2-3.0)*X1)
      BB(3,3)=2.0*(X2+1.0)*(1.0+A*X2)
      BB(4,3)=(X2+1.0)*(A*(X1*X2-3.0*X2+2.0)-X1*X2+3.0*X1-2.0)
C
      BB(1,4)=4.0*(1.0-A)*(A+X1)
      BB(2,4)=-BB(1,3)
      BB(3,4)=(0.0,0.0)
      BB(4,4)=2.0*(X2+1.0)*(A+X1)
C
      DO 100 J=1,4
      DO 100 I=1,4
      BB(I,J)=BB(I,J)*B
  100 CONTINUE
C
      RETURN
      END
C
C *** ANALITICAL INTEGRATIONS OF ASYMPTOTIC SOLUTIONS ***
C
      SUBROUTINE AINTG(R,LS,NL,QXS,QZS,VXS,WXS,WZS)
C
      COMPLEX QXS(0:2),QZS(0:2),VXS(0:2),WXS(0:2),WZS(0:2)
     *   ,SM1,X1,SM2,X2,SM3,X3,RM1,RM2,RM3,DC1,DC2,DC3
     *   ,H1T,H2T,H1D,H2D,H1R1,H2R1,H1R2,H2R2       
     *   ,CUPX,CUSX,CUP1X,CUS1X,CUP2X,CUS2X
     *   ,CDPX,CDSX,CDP1X,CDS1X,CDP2X,CDS2X
     *   ,CUPZ,CUSZ,CUP1Z,CUS1Z,CUP2Z,CUS2Z
     *   ,CDPZ,CDSZ,CDP1Z,CDS1Z,CDP2Z,CDS2Z
     *   ,DCUPT,DCUST,DCUPD,DCUSD,DCUPR,DCUSR
     *   ,DCDPT,DCDST,DCDPD,DCDSD,DCDPR,DCDSR
     *   ,D1MH1,DD0H1,D11H1,D1MH2,DD0H2,D1MH1R,DD0H1R,D1MH1Z,DD0H1Z
     *   ,D1MV1,DD0V1,D11V1,D01V2,D10V2,D1MV3,DD0V3,D10V4
     *   ,D1MV1R,DD0V1R,D10V2R,D1MV1Z,DD0V1Z,D10V2Z
     *   ,D01V1,D10V1,D00V2,D11V2,D10V3,D00V4
     *   ,D10V1R,D00V2R,D10V1Z,D00V2Z
      COMMON/ASYMP/SM1,X1,SM2,X2,SM3,X3 /RAM/RM1,RM2,RM3
     *      /DPSO /DEP1,DEP2,SDP,ODP 
     *      /HX  /H1T,H2T,H1D,H2D,H1R1,H2R1,H1R2,H2R2       
     *      /VUX /CUPX,CUSX,CUP1X,CUS1X,CUP2X,CUS2X
     *      /VDX /CDPX,CDSX,CDP1X,CDS1X,CDP2X,CDS2X
     *      /VUZ /CUPZ,CUSZ,CUP1Z,CUS1Z,CUP2Z,CUS2Z
     *      /VDZ /CDPZ,CDSZ,CDP1Z,CDS1Z,CDP2Z,CDS2Z
C
C *** ANALITICAL INTEGRATIONS ***
C
      IF(R.LT.1.0)THEN
        WRITE(1,*)
        WRITE(1,*)'FROM AINTG:R < 1.0; R=',R
        WRITE(1,*)'DEP1,DEP2,SDP,ODP',DEP1,DEP2,SDP,ODP
        R=1.0
        WRITE(1,*)'NEW R=',R
      END IF
C
C   * INTEGRATIONS FOR DIRECT WAVE *
C
      ZH=ABS(SDP-ODP)
      ZH2=ZH*ZH
      RR=SQRT(R*R+ZH2)
      R2=RR*RR
      R3=R2*RR
      R5=R3*R2
C
      S00=1.0/RR
      S01=ZH/R3
      S02=(3.0*ZH2/R2-1.0)/R3
      S03=3.0*ZH*(5.0*ZH2/R2-3.0)/R5
C
      S1M=R/(RR+ZH)
      S10=S1M/RR
      S11=R/R3
      S12=3.0*R*ZH/R5
      S13=3.0*R*(5.0*ZH2/R2-1.0)/R5
C
C   * INTEGRATIONS FOR REFLECTED WAVE FROM UPPER BOUNDARY *
C
      ZH=SDP+ODP-2.0*DEP1
      ZH2=ZH*ZH
      RR=SQRT(R*R+ZH2)
      R2=RR*RR
      R3=R2*RR
      R5=R3*R2
C
      S001=1.0/RR
      S011=ZH/R3
      S021=(3.0*ZH2/R2-1.0)/R3
      S031=3.0*ZH*(5.0*ZH2/R2-3.0)/R5
C
      S1M1=R/(RR+ZH)
      S101=S1M1/RR
      S111=R/R3
      S121=3.0*R*ZH/R5
      S131=3.0*R*(5.0*ZH2/R2-1.0)/R5
C
C   * INTEGRATIONS FOR REFLECTED WAVE FROM LOWER BOUNDARY *
C
      ZH=2.0*DEP2-SDP-ODP
      ZH2=ZH*ZH
      RR=SQRT(R*R+ZH2)
      R2=RR*RR
      R3=R2*RR
      R5=R3*R2
C
      S002=1.0/RR
      S012=ZH/R3
      S022=(3.0*ZH2/R2-1.0)/R3
      S032=3.0*ZH*(5.0*ZH2/R2-3.0)/R5
C
      S1M2=R/(RR+ZH)
      S102=S1M2/RR
      S112=R/R3
      S122=3.0*R*ZH/R5
      S132=3.0*R*(5.0*ZH2/R2-1.0)/R5
C
C *** ODP < DEP1 ***
C
      IF(ODP.GE.DEP1) GOTO 10
      IF(LS.EQ.1) GOTO 10
C
C  ** QX **
C
C   * SH (TRANSMITTED) *
C
      D1MH1=H1T*S1M
      DD0H1=H1T*(S00-S1M/R)
      QXS(0)=D1MH1/R
      VXS(0)=DD0H1
C
      D11H1=H1T*S11
      D1MH1R=DD0H1
      DD0H1R=(-DD0H1+D1MH1/R)/R-D11H1
      QXS(1)=(-D1MH1/R+D1MH1R)/R
      VXS(1)=DD0H1R
C
      D1MH2=H2T*S10
      DD0H2=H2T*(S01-S10/R)
      D1MH1Z=D1MH2/SM1
      DD0H1Z=DD0H2/SM1
      QXS(2)=D1MH1Z/R
      VXS(2)=DD0H1Z
C
C   * P-SV (TRANSMITTED) *
C
      HD1=SDP-DEP1
      D1Z=DEP1-ODP
      DC1=HD1*CUP2X
      DC2=HD1*CUS2X+D1Z*CUP1X
      DC3=D1Z*DC1
      DCUPT=CUP1X*S1M-DC1*S10
      DCUST=CUS1X*S1M-DC2*S10+DC3*S11
      D1MV1=DCUPT+DCUST
C
      DCUPT=CUP1X*S11-DC1*S12
      DCUST=CUS1X*S11-DC2*S12+DC3*S13
      D11V1=DCUPT+DCUST
      D10V4=SM1*((X1-1.0)*DCUPT-2.0*DCUST)
C
      S1=S00-S1M/R
      S2=S01-S10/R
      S3=S02-S11/R
      DCUPT=CUP1X*S1-DC1*S2
      DCUST=CUS1X*S1-DC2*S2+DC3*S3
      DD0V1=DCUPT+DCUST
C
      DCUPT=CUP1X*S01-DC1*S02
      DCUST=CUS1X*S01-DC2*S02+DC3*S03
      D01V2=(X1-1.0)*DCUPT-DCUST
C
      DCUPT=CUP1X*S10-DC1*S11
      DCUST=CUS1X*S10-DC2*S11+DC3*S12
      D10V2=(X1-1.0)*DCUPT-DCUST
      D1MV3=SM1*(-(X1-3.0)*DCUPT+2.0*DCUST)
C
      S1=S01-S10/R
      S2=S02-S11/R
      S3=S03-S12/R
      DCUPT=CUP1X*S1-DC1*S2
      DCUST=CUS1X*S1-DC2*S2+DC3*S3
      DD0V3=SM1*(-(X1-3.0)*DCUPT+2.0*DCUST)
C
      QXS(0)=QXS(0)+DD0V1
      VXS(0)=VXS(0)+D1MV1/R
      WXS(0)=D10V2
C
      D1MV1R=DD0V1
      DD0V1R=(-DD0V1+D1MV1/R)/R-D11V1
      D10V2R=D01V2-D10V2/R
C
      QXS(1)=QXS(1)+DD0V1R
      VXS(1)=VXS(1)+(-D1MV1/R+D1MV1R)/R
      WXS(1)=D10V2R
C
      D1MV1Z=D1MV3/SM1+D10V2
      DD0V1Z=DD0V3/SM1+D01V2-D10V2/R
      D10V2Z=(D10V4-RM1*D11V1)/(RM1+2.0*SM1) 
C
      QXS(2)=QXS(2)+DD0V1Z
      VXS(2)=VXS(2)+D1MV1Z/R
      WXS(2)=D10V2Z
C
C  ** QZ **
C
C   * P-SV (TRANSMITTED) *
C
      DC1=HD1*CUP2Z
      DC2=HD1*CUS2Z+D1Z*CUP1Z
      DC3=D1Z*DC1
      DCUPT=CUP1Z*S01-DC1*S02
      DCUST=CUS1Z*S01-DC2*S02+DC3*S03
      D01V1=DCUPT+DCUST
      D00V4=SM1*((X1-1.0)*DCUPT-2.0*DCUST)
C
      DCUPT=CUP1Z*S10-DC1*S11
      DCUST=CUS1Z*S10-DC2*S11+DC3*S12
      D10V1=DCUPT+DCUST
C
      DCUPT=CUP1Z*S00-DC1*S01
      DCUST=CUS1Z*S00-DC2*S01+DC3*S02
      D00V2=(X1-1.0)*DCUPT-DCUST
C
      DCUPT=CUP1Z*S11-DC1*S12
      DCUST=CUS1Z*S11-DC2*S12+DC3*S13
      D11V2=(X1-1.0)*DCUPT-DCUST
      D10V3=SM1*(-(X1-3.0)*DCUPT+2.0*DCUST)
C
      QZS(0)=D10V1
      WZS(0)=D00V2
C
      D10V1R=D01V1-D10V1/R
      D00V2R=-D11V2
C
      QZS(1)=D10V1R
      WZS(1)=D00V2R
C
      D10V1Z=D10V3/SM1+D11V2
      D00V2Z=(D00V4-RM1*D01V1)/(RM1+2.0*SM1)
C
      QZS(2)=D10V1Z
      WZS(2)=D00V2Z
C
      GOTO 50
C
C *** DEP1 < (OR =) ODP < SDP ***
C
   10 IF(ODP.GE.SDP) GOTO 20
C
C  ** QX **
C
C   * SH *
C
      D1MH1=H1D*S1M+H1R1*S1M1+H1R2*S1M2
      DD0H1=H1D*(S00-S1M/R)+H1R1*(S001-S1M1/R)+H1R2*(S002-S1M2/R)
      QXS(0)=D1MH1/R
      VXS(0)=DD0H1
C
      D11H1=H1D*S11+H1R1*S111+H1R2*S112
      D1MH1R=DD0H1
      DD0H1R=(-DD0H1+D1MH1/R)/R-D11H1
      QXS(1)=(-D1MH1/R+D1MH1R)/R
      VXS(1)=DD0H1R
C
      D1MH2=H2D*S10+H2R1*S101+H2R2*S102
      DD0H2=H2D*(S01-S10/R)+H2R1*(S011-S101/R)+H2R2*(S012-S102/R)
      D1MH1Z=D1MH2/SM2
      DD0H1Z=DD0H2/SM2
      QXS(2)=D1MH1Z/R
      VXS(2)=DD0H1Z
C
C   * P-SV (UP-GOING DIRECT) *
C
      DC1=(SDP-ODP)*CUPX
      DCUPD=CUPX*S1M
      DCUSD=CUSX*S1M-DC1*S10
      D1MV1=DCUPD+DCUSD
C
      DCUPD=CUPX*S11
      DCUSD=CUSX*S11-DC1*S12
      D11V1=DCUPD+DCUSD
      D10V4=SM2*((X2-1.0)*DCUPD-2.0*DCUSD)
C
      S1=S00-S1M/R
      S2=S01-S10/R
      DCUPD=CUPX*S1
      DCUSD=CUSX*S1-DC1*S2
      DD0V1=DCUPD+DCUSD
C
      DCUPD=CUPX*S01
      DCUSD=CUSX*S01-DC1*S02
      D01V2=(X2-1.0)*DCUPD-DCUSD
C
      DCUPD=CUPX*S10
      DCUSD=CUSX*S10-DC1*S11
      D10V2=(X2-1.0)*DCUPD-DCUSD
      D1MV3=SM2*(-(X2-3.0)*DCUPD+2.0*DCUSD)
C
      S1=S01-S10/R
      S2=S02-S11/R
      DCUPD=CUPX*S1
      DCUSD=CUSX*S1-DC1*S2
      DD0V3=SM2*(-(X2-3.0)*DCUPD+2.0*DCUSD)
C
      QXS(0)=QXS(0)+DD0V1
      VXS(0)=VXS(0)+D1MV1/R
      WXS(0)=D10V2
C
      D1MV1R=DD0V1
      DD0V1R=(-DD0V1+D1MV1/R)/R-D11V1
      D10V2R=D01V2-D10V2/R
C
      QXS(1)=QXS(1)+DD0V1R
      VXS(1)=VXS(1)+(-D1MV1/R+D1MV1R)/R
      WXS(1)=D10V2R
C
      D1MV1Z=D1MV3/SM2+D10V2
      DD0V1Z=DD0V3/SM2+D01V2-D10V2/R
      D10V2Z=(D10V4-RM2*D11V1)/(RM2+2.0*SM2) 
C
      QXS(2)=QXS(2)+DD0V1Z
      VXS(2)=VXS(2)+D1MV1Z/R
      WXS(2)=D10V2Z
C
C   * P-SV (DOWN-GOING REFLECTED FROM UPPER BOUNDARY) *
C
      HD1=SDP-DEP1
      ZD1=ODP-DEP1
      DC1=HD1*CDP2X
      DC2=HD1*CDS2X+ZD1*CDP1X
      DC3=ZD1*DC1
      DCDPR=CDP1X*S1M1-DC1*S101
      DCDSR=CDS1X*S1M1-DC2*S101+DC3*S111
      D1MV1=DCDPR+DCDSR
C
      DCDPR=CDP1X*S111-DC1*S121
      DCDSR=CDS1X*S111-DC2*S121+DC3*S131
      D11V1=DCDPR+DCDSR
      D10V4=SM2*((X2-1.0)*DCDPR-2.0*DCDSR)
C
      S1=S001-S1M1/R
      S2=S011-S101/R
      S3=S021-S111/R
      DCDPR=CDP1X*S1-DC1*S2
      DCDSR=CDS1X*S1-DC2*S2+DC3*S3
      DD0V1=DCDPR+DCDSR
C
      DCDPR=CDP1X*S011-DC1*S021
      DCDSR=CDS1X*S011-DC2*S021+DC3*S031
      D01V2=-(X2-1.0)*DCDPR+DCDSR
C
      DCDPR=CDP1X*S101-DC1*S111
      DCDSR=CDS1X*S101-DC2*S111+DC3*S121
      D10V2=-(X2-1.0)*DCDPR+DCDSR
      D1MV3=SM2*((X2-3.0)*DCDPR-2.0*DCDSR)
C
      S1=S011-S101/R
      S2=S021-S111/R
      S3=S031-S121/R
      DCDPR=CDP1X*S1-DC1*S2
      DCDSR=CDS1X*S1-DC2*S2+DC3*S3
      DD0V3=SM2*((X2-3.0)*DCDPR-2.0*DCDSR)
C
      QXS(0)=QXS(0)+DD0V1
      VXS(0)=VXS(0)+D1MV1/R
      WXS(0)=WXS(0)+D10V2
C
      D1MV1R=DD0V1
      DD0V1R=(-DD0V1+D1MV1/R)/R-D11V1
      D10V2R=D01V2-D10V2/R
C
      QXS(1)=QXS(1)+DD0V1R
      VXS(1)=VXS(1)+(-D1MV1/R+D1MV1R)/R
      WXS(1)=WXS(1)+D10V2R
C
      D1MV1Z=D1MV3/SM2+D10V2
      DD0V1Z=DD0V3/SM2+D01V2-D10V2/R
      D10V2Z=(D10V4-RM2*D11V1)/(RM2+2.0*SM2) 
C
      QXS(2)=QXS(2)+DD0V1Z
      VXS(2)=VXS(2)+D1MV1Z/R
      WXS(2)=WXS(2)+D10V2Z
C
C   * P-SV (UP-GOING REFLECTED FROM LOWER BOUNDARY) *
C
      IF(LS.EQ.NL)GOTO 15
C
      D2H=DEP2-SDP
      D2Z=DEP2-ODP
      DC1=D2H*CUP2X
      DC2=D2H*CUS2X+D2Z*CUP1X
      DC3=D2Z*DC1
      DCUPR=CUP1X*S1M2-DC1*S102
      DCUSR=CUS1X*S1M2-DC2*S102+DC3*S112
      D1MV1=DCUPR+DCUSR
C
      DCUPR=CUP1X*S112-DC1*S122
      DCUSR=CUS1X*S112-DC2*S122+DC3*S132
      D11V1=DCUPR+DCUSR
      D10V4=SM2*((X2-1.0)*DCUPR-2.0*DCUSR)
C
      S1=S002-S1M2/R
      S2=S012-S102/R
      S3=S022-S112/R
      DCUPR=CUP1X*S1-DC1*S2
      DCUSR=CUS1X*S1-DC2*S2+DC3*S3
      DD0V1=DCUPR+DCUSR
C
      DCUPR=CUP1X*S012-DC1*S022
      DCUSR=CUS1X*S012-DC2*S022+DC3*S032
      D01V2=(X2-1.0)*DCUPR-DCUSR
C
      DCUPR=CUP1X*S102-DC1*S112
      DCUSR=CUS1X*S102-DC2*S112+DC3*S122
      D10V2=(X2-1.0)*DCUPR-DCUSR
      D1MV3=SM2*(-(X2-3.0)*DCUPR+2.0*DCUSR)
C
      S1=S012-S102/R
      S2=S022-S112/R
      S3=S032-S122/R
      DCUPR=CUP1X*S1-DC1*S2
      DCUSR=CUS1X*S1-DC2*S2+DC3*S3
      DD0V3=SM2*(-(X2-3.0)*DCUPR+2.0*DCUSR)
C
      QXS(0)=QXS(0)+DD0V1
      VXS(0)=VXS(0)+D1MV1/R
      WXS(0)=WXS(0)+D10V2
C
      D1MV1R=DD0V1
      DD0V1R=(-DD0V1+D1MV1/R)/R-D11V1
      D10V2R=D01V2-D10V2/R
C
      QXS(1)=QXS(1)+DD0V1R
      VXS(1)=VXS(1)+(-D1MV1/R+D1MV1R)/R
      WXS(1)=WXS(1)+D10V2R
C
      D1MV1Z=D1MV3/SM2+D10V2
      DD0V1Z=DD0V3/SM2+D01V2-D10V2/R
      D10V2Z=(D10V4-RM2*D11V1)/(RM2+2.0*SM2) 
C
      QXS(2)=QXS(2)+DD0V1Z
      VXS(2)=VXS(2)+D1MV1Z/R
      WXS(2)=WXS(2)+D10V2Z
C
C  ** QZ **
C
   15 DC1=(SDP-ODP)*CUPZ
      DCUPD=CUPZ*S01
      DCUSD=CUSZ*S01-DC1*S02
      D01V1=DCUPD+DCUSD
      D00V4=SM2*((X2-1.0)*DCUPD-2.0*DCUSD)
C
      DCUPD=CUPZ*S10
      DCUSD=CUSZ*S10-DC1*S11
      D10V1=DCUPD+DCUSD
C
      DCUPD=CUPZ*S00
      DCUSD=CUSZ*S00-DC1*S01
      D00V2=(X2-1.0)*DCUPD-DCUSD
C
      DCUPD=CUPZ*S11
      DCUSD=CUSZ*S11-DC1*S12
      D11V2=(X2-1.0)*DCUPD-DCUSD
      D10V3=SM2*(-(X2-3.0)*DCUPD+2.0*DCUSD)
C
      QZS(0)=D10V1
      WZS(0)=D00V2
C
      D10V1R=D01V1-D10V1/R
      D00V2R=-D11V2
C
      QZS(1)=D10V1R
      WZS(1)=D00V2R
C
      D10V1Z=D10V3/SM2+D11V2
      D00V2Z=(D00V4-RM2*D01V1)/(RM2+2.0*SM2)
C
      QZS(2)=D10V1Z
      WZS(2)=D00V2Z
C
      DC1=HD1*CDP2Z
      DC2=HD1*CDS2Z+ZD1*CDP1Z
      DC3=ZD1*DC1
      DCDPR=CDP1Z*S011-DC1*S021
      DCDSR=CDS1Z*S011-DC2*S021+DC3*S031
      D01V1=DCDPR+DCDSR
      D00V4=SM2*((X2-1.0)*DCDPR-2.0*DCDSR)
C
      DCDPR=CDP1Z*S101-DC1*S111
      DCDSR=CDS1Z*S101-DC2*S111+DC3*S121
      D10V1=DCDPR+DCDSR
C
      DCDPR=CDP1Z*S001-DC1*S011
      DCDSR=CDS1Z*S001-DC2*S011+DC3*S021
      D00V2=-(X2-1.0)*DCDPR+DCDSR
C
      DCDPR=CDP1Z*S111-DC1*S121
      DCDSR=CDS1Z*S111-DC2*S121+DC3*S131
      D11V2=-(X2-1.0)*DCDPR+DCDSR
      D10V3=SM2*((X2-3.0)*DCDPR-2.0*DCDSR)
C
      QZS(0)=QZS(0)+D10V1
      WZS(0)=WZS(0)+D00V2
C
      D10V1R=D01V1-D10V1/R
      D00V2R=-D11V2
C
      QZS(1)=QZS(1)+D10V1R
      WZS(1)=WZS(1)+D00V2R
C
      D10V1Z=D10V3/SM2+D11V2
      D00V2Z=(D00V4-RM2*D01V1)/(RM2+2.0*SM2)
C
      QZS(2)=QZS(2)+D10V1Z
      WZS(2)=WZS(2)+D00V2Z
C
      IF(LS.EQ.NL)GOTO 50
C
      DC1=D2H*CUP2Z
      DC2=D2H*CUS2Z+D2Z*CUP1Z
      DC3=D2Z*DC1
      DCUPR=CUP1Z*S012-DC1*S022
      DCUSR=CUS1Z*S012-DC2*S022+DC3*S032
      D01V1=DCUPR+DCUSR
      D00V4=SM2*((X2-1.0)*DCUPR-2.0*DCUSR)
C
      DCUPR=CUP1Z*S102-DC1*S112
      DCUSR=CUS1Z*S102-DC2*S112+DC3*S122
      D10V1=DCUPR+DCUSR
C
      DCUPR=CUP1Z*S002-DC1*S012
      DCUSR=CUS1Z*S002-DC2*S012+DC3*S022
      D00V2=(X2-1.0)*DCUPR-DCUSR
C
      DCUPR=CUP1Z*S112-DC1*S122
      DCUSR=CUS1Z*S112-DC2*S122+DC3*S132
      D11V2=(X2-1.0)*DCUPR-DCUSR
      D10V3=SM2*(-(X2-3.0)*DCUPR+2.0*DCUSR)
C
      QZS(0)=QZS(0)+D10V1
      WZS(0)=WZS(0)+D00V2
C
      D10V1R=D01V1-D10V1/R
      D00V2R=-D11V2
C
      QZS(1)=QZS(1)+D10V1R
      WZS(1)=WZS(1)+D00V2R
C
      D10V1Z=D10V3/SM2+D11V2
      D00V2Z=(D00V4-RM2*D01V1)/(RM2+2.0*SM2)
C
      QZS(2)=QZS(2)+D10V1Z
      WZS(2)=WZS(2)+D00V2Z
C
      GOTO 50
C
C *** SDP < (OR =) ODP < DEP2 ***
C
   20 IF((LS.NE.NL).AND.(ODP.GE.DEP2)) GOTO 30
C
C  ** QX **
C
C   * SH *
C
      D1MH1=H1D*S1M+H1R1*S1M1+H1R2*S1M2
      DD0H1=H1D*(S00-S1M/R)+H1R1*(S001-S1M1/R)+H1R2*(S002-S1M2/R)
      QXS(0)=D1MH1/R
      VXS(0)=DD0H1
C
      D11H1=H1D*S11+H1R1*S111+H1R2*S112
      D1MH1R=DD0H1
      DD0H1R=(-DD0H1+D1MH1/R)/R-D11H1
      QXS(1)=(-D1MH1/R+D1MH1R)/R
      VXS(1)=DD0H1R
C
      D1MH2=-H2D*S10+H2R1*S101+H2R2*S102
      DD0H2=-H2D*(S01-S10/R)+H2R1*(S011-S101/R)+H2R2*(S012-S102/R)
      D1MH1Z=D1MH2/SM2
      DD0H1Z=DD0H2/SM2
      QXS(2)=D1MH1Z/R
      VXS(2)=DD0H1Z
C
C   * P-SV (DOWN-GOING DIRECT) *
C
      DC1=(ODP-SDP)*CDPX
      DCDPD=CDPX*S1M
      DCDSD=CDSX*S1M-DC1*S10
      D1MV1=DCDPD+DCDSD
C
      DCDPD=CDPX*S11
      DCDSD=CDSX*S11-DC1*S12
      D11V1=DCDPD+DCDSD
      D10V4=SM2*((X2-1.0)*DCDPD-2.0*DCDSD)
C
      S1=S00-S1M/R
      S2=S01-S10/R
      DCDPD=CDPX*S1
      DCDSD=CDSX*S1-DC1*S2
      DD0V1=DCDPD+DCDSD
C
      DCDPD=CDPX*S01
      DCDSD=CDSX*S01-DC1*S02
      D01V2=-(X2-1.0)*DCDPD+DCDSD
C
      DCDPD=CDPX*S10
      DCDSD=CDSX*S10-DC1*S11
      D10V2=-(X2-1.0)*DCDPD+DCDSD
      D1MV3=SM2*((X2-3.0)*DCDPD-2.0*DCDSD)
C
      S1=S01-S10/R
      S2=S02-S11/R
      DCDPD=CDPX*S1
      DCDSD=CDSX*S1-DC1*S2
      DD0V3=SM2*((X2-3.0)*DCDPD-2.0*DCDSD)
C
      QXS(0)=QXS(0)+DD0V1
      VXS(0)=VXS(0)+D1MV1/R
      WXS(0)=D10V2
C
      D1MV1R=DD0V1
      DD0V1R=(-DD0V1+D1MV1/R)/R-D11V1
      D10V2R=D01V2-D10V2/R
C
      QXS(1)=QXS(1)+DD0V1R
      VXS(1)=VXS(1)+(-D1MV1/R+D1MV1R)/R
      WXS(1)=D10V2R
C
      D1MV1Z=D1MV3/SM2+D10V2
      DD0V1Z=DD0V3/SM2+D01V2-D10V2/R
      D10V2Z=(D10V4-RM2*D11V1)/(RM2+2.0*SM2) 
C
      QXS(2)=QXS(2)+DD0V1Z
      VXS(2)=VXS(2)+D1MV1Z/R
      WXS(2)=D10V2Z
C
C   * P-SV (UP-GOING REFLECTED FROM LOWER BOUNDARY) *
C
      IF(LS.EQ.NL)GOTO 25
C
      D2H=DEP2-SDP
      D2Z=DEP2-ODP
      DC1=D2H*CUP2X
      DC2=D2H*CUS2X+D2Z*CUP1X
      DC3=D2Z*DC1
      DCUPR=CUP1X*S1M2-DC1*S102
      DCUSR=CUS1X*S1M2-DC2*S102+DC3*S112
      D1MV1=DCUPR+DCUSR
C
      DCUPR=CUP1X*S112-DC1*S122
      DCUSR=CUS1X*S112-DC2*S122+DC3*S132
      D11V1=DCUPR+DCUSR
      D10V4=SM2*((X2-1.0)*DCUPR-2.0*DCUSR)
C
      S1=S002-S1M2/R
      S2=S012-S102/R
      S3=S022-S112/R
      DCUPR=CUP1X*S1-DC1*S2
      DCUSR=CUS1X*S1-DC2*S2+DC3*S3
      DD0V1=DCUPR+DCUSR
C
      DCUPR=CUP1X*S012-DC1*S022
      DCUSR=CUS1X*S012-DC2*S022+DC3*S032
      D01V2=(X2-1.0)*DCUPR-DCUSR
C
      DCUPR=CUP1X*S102-DC1*S112
      DCUSR=CUS1X*S102-DC2*S112+DC3*S122
      D10V2=(X2-1.0)*DCUPR-DCUSR
      D1MV3=SM2*(-(X2-3.0)*DCUPR+2.0*DCUSR)
C
      S1=S012-S102/R
      S2=S022-S112/R
      S3=S032-S122/R
      DCUPR=CUP1X*S1-DC1*S2
      DCUSR=CUS1X*S1-DC2*S2+DC3*S3
      DD0V3=SM2*(-(X2-3.0)*DCUPR+2.0*DCUSR)
C
      QXS(0)=QXS(0)+DD0V1
      VXS(0)=VXS(0)+D1MV1/R
      WXS(0)=WXS(0)+D10V2
C
      D1MV1R=DD0V1
      DD0V1R=(-DD0V1+D1MV1/R)/R-D11V1
      D10V2R=D01V2-D10V2/R
C
      QXS(1)=QXS(1)+DD0V1R
      VXS(1)=VXS(1)+(-D1MV1/R+D1MV1R)/R
      WXS(1)=WXS(1)+D10V2R
C
      D1MV1Z=D1MV3/SM2+D10V2
      DD0V1Z=DD0V3/SM2+D01V2-D10V2/R
      D10V2Z=(D10V4-RM2*D11V1)/(RM2+2.0*SM2) 
C
      QXS(2)=QXS(2)+DD0V1Z
      VXS(2)=VXS(2)+D1MV1Z/R
      WXS(2)=WXS(2)+D10V2Z
C
C   * P-SV (DOWN-GOING REFLECTED FROM UPPER BOUNDARY) *
C
   25 HD1=SDP-DEP1
      ZD1=ODP-DEP1
      DC1=HD1*CDP2X
      DC2=HD1*CDS2X+ZD1*CDP1X
      DC3=ZD1*DC1
      DCDPR=CDP1X*S1M1-DC1*S101
      DCDSR=CDS1X*S1M1-DC2*S101+DC3*S111
      D1MV1=DCDPR+DCDSR
C
      DCDPR=CDP1X*S111-DC1*S121
      DCDSR=CDS1X*S111-DC2*S121+DC3*S131
      D11V1=DCDPR+DCDSR
      D10V4=SM2*((X2-1.0)*DCDPR-2.0*DCDSR)
C
      S1=S001-S1M1/R
      S2=S011-S101/R
      S3=S021-S111/R
      DCDPR=CDP1X*S1-DC1*S2
      DCDSR=CDS1X*S1-DC2*S2+DC3*S3
      DD0V1=DCDPR+DCDSR
C
      DCDPR=CDP1X*S011-DC1*S021
      DCDSR=CDS1X*S011-DC2*S021+DC3*S031
      D01V2=-(X2-1.0)*DCDPR+DCDSR
C
      DCDPR=CDP1X*S101-DC1*S111
      DCDSR=CDS1X*S101-DC2*S111+DC3*S121
      D10V2=-(X2-1.0)*DCDPR+DCDSR
      D1MV3=SM2*((X2-3.0)*DCDPR-2.0*DCDSR)
C
      S1=S011-S101/R
      S2=S021-S111/R
      S3=S031-S121/R
      DCDPR=CDP1X*S1-DC1*S2
      DCDSR=CDS1X*S1-DC2*S2+DC3*S3
      DD0V3=SM2*((X2-3.0)*DCDPR-2.0*DCDSR)
C
      QXS(0)=QXS(0)+DD0V1
      VXS(0)=VXS(0)+D1MV1/R
      WXS(0)=WXS(0)+D10V2
C
      D1MV1R=DD0V1
      DD0V1R=(-DD0V1+D1MV1/R)/R-D11V1
      D10V2R=D01V2-D10V2/R
C
      QXS(1)=QXS(1)+DD0V1R
      VXS(1)=VXS(1)+(-D1MV1/R+D1MV1R)/R
      WXS(1)=WXS(1)+D10V2R
C
      D1MV1Z=D1MV3/SM2+D10V2
      DD0V1Z=DD0V3/SM2+D01V2-D10V2/R
      D10V2Z=(D10V4-RM2*D11V1)/(RM2+2.0*SM2) 
C
      QXS(2)=QXS(2)+DD0V1Z
      VXS(2)=VXS(2)+D1MV1Z/R
      WXS(2)=WXS(2)+D10V2Z
C
C  ** QZ **
C
      DC1=(ODP-SDP)*CDPZ
      DCDPD=CDPZ*S01
      DCDSD=CDSZ*S01-DC1*S02
      D01V1=DCDPD+DCDSD
      D00V4=SM2*((X2-1.0)*DCDPD-2.0*DCDSD)
C
      DCDPD=CDPZ*S10
      DCDSD=CDSZ*S10-DC1*S11
      D10V1=DCDPD+DCDSD
C
      DCDPD=CDPZ*S00
      DCDSD=CDSZ*S00-DC1*S01
      D00V2=-(X2-1.0)*DCDPD+DCDSD
C
      DCDPD=CDPZ*S11
      DCDSD=CDSZ*S11-DC1*S12
      D11V2=-(X2-1.0)*DCDPD+DCDSD
      D10V3=SM2*((X2-3.0)*DCDPD-2.0*DCDSD)
C
      QZS(0)=D10V1
      WZS(0)=D00V2
C
      D10V1R=D01V1-D10V1/R
      D00V2R=-D11V2
C
      QZS(1)=D10V1R
      WZS(1)=D00V2R
C
      D10V1Z=D10V3/SM2+D11V2
      D00V2Z=(D00V4-RM2*D01V1)/(RM2+2.0*SM2)
C
      QZS(2)=D10V1Z
      WZS(2)=D00V2Z
C
      IF(LS.EQ.NL)GOTO 27
C
      DC1=D2H*CUP2Z
      DC2=D2H*CUS2Z+D2Z*CUP1Z
      DC3=D2Z*DC1
      DCUPR=CUP1Z*S012-DC1*S022
      DCUSR=CUS1Z*S012-DC2*S022+DC3*S032
      D01V1=DCUPR+DCUSR
      D00V4=SM2*((X2-1.0)*DCUPR-2.0*DCUSR)
C
      DCUPR=CUP1Z*S102-DC1*S112
      DCUSR=CUS1Z*S102-DC2*S112+DC3*S122
      D10V1=DCUPR+DCUSR
C
      DCUPR=CUP1Z*S002-DC1*S012
      DCUSR=CUS1Z*S002-DC2*S012+DC3*S022
      D00V2=(X2-1.0)*DCUPR-DCUSR
C
      DCUPR=CUP1Z*S112-DC1*S122
      DCUSR=CUS1Z*S112-DC2*S122+DC3*S132
      D11V2=(X2-1.0)*DCUPR-DCUSR
      D10V3=SM2*(-(X2-3.0)*DCUPR+2.0*DCUSR)
C
      QZS(0)=QZS(0)+D10V1
      WZS(0)=WZS(0)+D00V2
C
      D10V1R=D01V1-D10V1/R
      D00V2R=-D11V2
C
      QZS(1)=QZS(1)+D10V1R
      WZS(1)=WZS(1)+D00V2R
C
      D10V1Z=D10V3/SM2+D11V2
      D00V2Z=(D00V4-RM2*D01V1)/(RM2+2.0*SM2)
C
      QZS(2)=QZS(2)+D10V1Z
      WZS(2)=WZS(2)+D00V2Z
C
   27 DC1=HD1*CDP2Z
      DC2=HD1*CDS2Z+ZD1*CDP1Z
      DC3=ZD1*DC1
      DCDPR=CDP1Z*S011-DC1*S021
      DCDSR=CDS1Z*S011-DC2*S021+DC3*S031
      D01V1=DCDPR+DCDSR
      D00V4=SM2*((X2-1.0)*DCDPR-2.0*DCDSR)
C
      DCDPR=CDP1Z*S101-DC1*S111
      DCDSR=CDS1Z*S101-DC2*S111+DC3*S121
      D10V1=DCDPR+DCDSR
C
      DCDPR=CDP1Z*S001-DC1*S011
      DCDSR=CDS1Z*S001-DC2*S011+DC3*S021
      D00V2=-(X2-1.0)*DCDPR+DCDSR
C
      DCDPR=CDP1Z*S111-DC1*S121
      DCDSR=CDS1Z*S111-DC2*S121+DC3*S131
      D11V2=-(X2-1.0)*DCDPR+DCDSR
      D10V3=SM2*((X2-3.0)*DCDPR-2.0*DCDSR)
C
      QZS(0)=QZS(0)+D10V1
      WZS(0)=WZS(0)+D00V2
C
      D10V1R=D01V1-D10V1/R
      D00V2R=-D11V2
C
      QZS(1)=QZS(1)+D10V1R
      WZS(1)=WZS(1)+D00V2R
C
      D10V1Z=D10V3/SM2+D11V2
      D00V2Z=(D00V4-RM2*D01V1)/(RM2+2.0*SM2)
C
      QZS(2)=QZS(2)+D10V1Z
      WZS(2)=WZS(2)+D00V2Z
C
      GOTO 50
C
C *** SDP < (OR =) ODP < DEP2 ***
C
C  ** QX **
C
C   * SH (TRANSMITTED) *
C
   30 D1MH1=H1T*S1M
      DD0H1=H1T*(S00-S1M/R)
      QXS(0)=D1MH1/R
      VXS(0)=DD0H1
C
      D11H1=H1T*S11
      D1MH1R=DD0H1
      DD0H1R=(-DD0H1+D1MH1/R)/R-D11H1
      QXS(1)=(-D1MH1/R+D1MH1R)/R
      VXS(1)=DD0H1R
C
      D1MH2=H2T*S10
      DD0H2=H2T*(S01-S10/R)
      D1MH1Z=D1MH2/SM3
      DD0H1Z=DD0H2/SM3
      QXS(2)=D1MH1Z/R
      VXS(2)=DD0H1Z
C
C   * P-SV (TRANSMITTED) *
C
      D2H=DEP2-SDP
      ZD2=ODP-DEP2
      DC1=D2H*CDP2X
      DC2=D2H*CDS2X+ZD2*CDP1X
      DC3=ZD2*DC1
      DCDPT=CDP1X*S1M-DC1*S10
      DCDST=CDS1X*S1M-DC2*S10+DC3*S11
      D1MV1=DCDPT+DCDST
C
      DCDPT=CDP1X*S11-DC1*S12
      DCDST=CDS1X*S11-DC2*S12+DC3*S13
      D11V1=DCDPT+DCDST
      D10V4=SM3*((X3-1.0)*DCDPT-2.0*DCDST)
C
      S1=S00-S1M/R
      S2=S01-S10/R
      S3=S02-S11/R
      DCDPT=CDP1X*S1-DC1*S2
      DCDST=CDS1X*S1-DC2*S2+DC3*S3
      DD0V1=DCDPT+DCDST
C
      DCDPT=CDP1X*S01-DC1*S02
      DCDST=CDS1X*S01-DC2*S02+DC3*S03
      D01V2=-(X3-1.0)*DCDPT+DCDST
C
      DCDPT=CDP1X*S10-DC1*S11
      DCDST=CDS1X*S10-DC2*S11+DC3*S12
      D10V2=-(X3-1.0)*DCDPT+DCDST
      D1MV3=SM3*((X3-3.0)*DCDPT-2.0*DCDST)
C
      S1=S01-S10/R
      S2=S02-S11/R
      S3=S03-S12/R
      DCDPT=CDP1X*S1-DC1*S2
      DCDST=CDS1X*S1-DC2*S2+DC3*S3
      DD0V3=SM3*((X3-3.0)*DCDPT-2.0*DCDST)
C
      QXS(0)=QXS(0)+DD0V1
      VXS(0)=VXS(0)+D1MV1/R
      WXS(0)=D10V2
C
      D1MV1R=DD0V1
      DD0V1R=(-DD0V1+D1MV1/R)/R-D11V1
      D10V2R=D01V2-D10V2/R
C
      QXS(1)=QXS(1)+DD0V1R
      VXS(1)=VXS(1)+(-D1MV1/R+D1MV1R)/R
      WXS(1)=D10V2R
C
      D1MV1Z=D1MV3/SM3+D10V2
      DD0V1Z=DD0V3/SM3+D01V2-D10V2/R
      D10V2Z=(D10V4-RM3*D11V1)/(RM3+2.0*SM3) 
C
      QXS(2)=QXS(2)+DD0V1Z
      VXS(2)=VXS(2)+D1MV1Z/R
      WXS(2)=D10V2Z
C
C  ** QZ **
C
      DC1=D2H*CDP2Z
      DC2=D2H*CDS2Z+ZD2*CDP1Z
      DC3=ZD2*DC1
      DCDPT=CDP1Z*S01-DC1*S02
      DCDST=CDS1Z*S01-DC2*S02+DC3*S03
      D01V1=DCDPT+DCDST
      D00V4=SM3*((X3-1.0)*DCDPT-2.0*DCDST)
C
      DCDPT=CDP1Z*S10-DC1*S11
      DCDST=CDS1Z*S10-DC2*S11+DC3*S12
      D10V1=DCDPT+DCDST
C
      DCDPT=CDP1Z*S00-DC1*S01
      DCDST=CDS1Z*S00-DC2*S01+DC3*S02
      D00V2=-(X3-1.0)*DCDPT+DCDST
C
      DCDPT=CDP1Z*S11-DC1*S12
      DCDST=CDS1Z*S11-DC2*S12+DC3*S13
      D11V2=-(X3-1.0)*DCDPT+DCDST
      D10V3=SM3*((X3-3.0)*DCDPT-2.0*DCDST)
C
      QZS(0)=D10V1
      WZS(0)=D00V2
C
      D10V1R=D01V1-D10V1/R
      D00V2R=-D11V2
C
      QZS(1)=D10V1R
      WZS(1)=D00V2R
C
      D10V1Z=D10V3/SM3+D11V2
      D00V2Z=(D00V4-RM3*D01V1)/(RM3+2.0*SM3)
C
      QZS(2)=D10V1Z
      WZS(2)=D00V2Z
C
   50 RETURN
      END
C
C *** SH GENERALIZED R/T MATIX ***
C
      SUBROUTINE GNRTSH(OM,WN)
C
      COMPLEX VP,VS,GTD,GTU,GRD,GRU,TD,TU,RD,RU
      COMMON /SOLY/LS,SDEP,LO,ODEP
     *    /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
      COMMON /GRTSH/GTD(0:20),GTU(0:20),GRD(0:20),GRU(0:20)
     *    /MRTSH/TD(0:20),TU(0:20),RD(0:20),RU(0:20)
C
C *** CHECK FOR THE DIMENSION OF GTD, GTU, GRD, AND GRU ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM GNRTSH: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** MODIFIED R/T MATRIX ***
C
      CALL MDRTSH(OM,WN)
C
C *** GENERALIZED R/T MATRIX ***
C
      GRU(0)=RU(0)
      DO 100 I=1,LS-1
        GTU(I)=TU(I)/(1.0-RD(I)*GRU(I-1))
        GRU(I)=RU(I)+TD(I)*GRU(I-1)*GTU(I)
  100 CONTINUE
C
      GTD(NL-1)=TD(NL-1)
      GRD(NL-1)=RD(NL-1)
      DO 200 I=NL-2,LS,-1
        GTD(I)=TD(I)/(1.0-RU(I)*GRD(I+1))
        GRD(I)=RD(I)+TU(I)*GRD(I+1)*GTD(I)
  200 CONTINUE
C
      RETURN
      END
C
C
C
C *** SH MODIFIED R/T MATIX ***
C
      SUBROUTINE MDRTSH(OM,WN)
C
      COMPLEX VP,VS,VS2,WS2,CMS,SM,EA(2,2),EB(2,2)
     *      ,TD,TU,RD,RU,DDA,DUB,EAB
      COMMON /SOLY/LS,SDEP,LO,ODEP
     *    /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
      COMMON /MRTSH/TD(0:20),TU(0:20),RD(0:20),RU(0:20)
C
C *** CHECK FOR THE DIMENSION OF TD, TU, RD, AND RU ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM MDRTSH: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** MODIFIED R/T MATRIX ***
C
      WN2=WN*WN
      OM2=OM*OM
C
      VS2=VS(1)*VS(1)
      WS2=OM2/VS2
      CMS=CSQRT(WN2-WS2)
      IF(REAL(CMS).LT.0.0)CMS=-CMS
C
      SM=DNS(1)*VS2
      EA(1,1)=(1.0,0.0)
      EA(1,2)=(1.0,0.0)
      EA(2,1)=-SM*CMS
      EA(2,2)= SM*CMS
C
      IF(NL.EQ.1)THEN
        DUB=CEXP(-CMS*SDEP)
        RU(0)=-EA(2,2)*DUB/EA(2,1)
        RETURN
      END IF
C
      IF(LS.EQ.1)THEN
        DUB=CEXP(-CMS*SDEP)
        DDA=CEXP(-CMS*(THK(1)-SDEP))
      ELSE
        DUB=CEXP(-CMS*THK(1))
        DDA=DUB
      END IF
C
      RU(0)=-EA(2,2)*DUB/EA(2,1)
C
      DO 100 I=1, NL-2
C
        VS2=VS(I+1)*VS(I+1)
        WS2=OM2/VS2
        CMS=CSQRT(WN2-WS2)
        IF(REAL(CMS).LT.0.0)CMS=-CMS
C
        SM=DNS(I+1)*VS2
        EB(1,1)=(1.0,0.0)
        EB(1,2)=(1.0,0.0)
        EB(2,1)=-SM*CMS
        EB(2,2)= SM*CMS
C
        IF(LS.EQ.(I+1))THEN
          DUB=CEXP(-CMS*SDEP)
        ELSE
          DUB=CEXP(-CMS*THK(I+1))
        END IF
C
        EAB=EB(2,1)*EA(1,2)-EB(1,1)*EA(2,2) 
        TD(I)=(EA(1,2)*EA(2,1)-EA(1,1)*EA(2,2))*DDA/EAB
        RU(I)=(EB(1,2)*EA(2,2)-EB(2,2)*EA(1,2))*DUB/EAB
        RD(I)=(EB(1,1)*EA(2,1)-EA(1,1)*EB(2,1))*DDA/EAB
        TU(I)=(EB(1,2)*EB(2,1)-EB(2,2)*EB(1,1))*DUB/EAB
C
        EA(1,1)=EB(1,1)
        EA(1,2)=EB(1,2)
        EA(2,1)=EB(2,1)
        EA(2,2)=EB(2,2)
C
        IF(LS.EQ.(I+1))THEN
          DDA=CEXP(-CMS*(THK(I+1)-SDEP))
        ELSE          
          DDA=DUB
        END IF
C
  100 CONTINUE
C        
      VS2=VS(NL)*VS(NL)
      WS2=OM2/VS2
      CMS=CSQRT(WN2-WS2)
      IF(REAL(CMS).LT.0.0)CMS=-CMS
C
      SM=DNS(NL)*VS2
      EB(1,1)=(1.0,0.0)
      EB(1,2)=(1.0,0.0)
      EB(2,1)=-SM*CMS
      EB(2,2)= SM*CMS
C
      EAB=EB(2,1)*EA(1,2)-EB(1,1)*EA(2,2) 
C
      IF(LS.EQ.NL)THEN
C
        DUB=CEXP(-CMS*SDEP)
        TD(NL-1)=(EA(1,2)*EA(2,1)-EA(1,1)*EA(2,2))*DDA/EAB
        RU(NL-1)=(EB(1,2)*EA(2,2)-EB(2,2)*EA(1,2))*DUB/EAB
        RD(NL-1)=(EB(1,1)*EA(2,1)-EA(1,1)*EB(2,1))*DDA/EAB
        TU(NL-1)=(EB(1,2)*EB(2,1)-EB(2,2)*EB(1,1))*DUB/EAB
C
      ELSE
C
        TD(NL-1)=(EA(1,2)*EA(2,1)-EA(1,1)*EA(2,2))*DDA/EAB
        RD(NL-1)=(EB(1,1)*EA(2,1)-EA(1,1)*EB(2,1))*DDA/EAB
C
      END IF
C
      RETURN
      END
C
C
C
C *** P-SV GENERALIZED R/T MATIX ***
C
      SUBROUTINE GNRTPSV(OM,WN)
C
      COMPLEX VP,VS,GTD,GTU,GRD,GRU,TD,TU,RD,RU,E1(2,2),E2(2,2),DT
      COMMON /SOLY/LS,SDEP,LO,ODEP
     *    /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
      COMMON /MRTPSV/TD(2,2,0:20),TU(2,2,0:20),RD(2,2,0:20),RU(2,2,0:20)
     *  /GRTPSV/GTD(2,2,0:20),GTU(2,2,0:20),GRD(2,2,0:20),GRU(2,2,0:20)
C
C *** CHECK FOR THE DIMENSION OF GTD, GTU, GRD, AND GRU ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM GNRTPSV: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** MODIFIED R/T MATRIX ***
C
      CALL MDRTPSV(OM,WN)
C
C *** GENERALIZED R/T MATRIX ***
C
      GRU(1,1,0)=RU(1,1,0)
      GRU(1,2,0)=RU(1,2,0)
      GRU(2,1,0)=RU(2,1,0)
      GRU(2,2,0)=RU(2,2,0)
C
      DO 100 I=1,LS-1
C
        E1(1,1)=1.0-RD(1,1,I)*GRU(1,1,I-1)-RD(1,2,I)*GRU(2,1,I-1)
        E1(1,2)=   -RD(1,1,I)*GRU(1,2,I-1)-RD(1,2,I)*GRU(2,2,I-1)
        E1(2,1)=   -RD(2,1,I)*GRU(1,1,I-1)-RD(2,2,I)*GRU(2,1,I-1)
        E1(2,2)=1.0-RD(2,1,I)*GRU(1,2,I-1)-RD(2,2,I)*GRU(2,2,I-1)
        DT=E1(1,1)*E1(2,2)-E1(1,2)*E1(2,1)
        E2(1,1)= E1(2,2)/DT
        E2(1,2)=-E1(1,2)/DT
        E2(2,1)=-E1(2,1)/DT
        E2(2,2)= E1(1,1)/DT
        GTU(1,1,I)=E2(1,1)*TU(1,1,I)+E2(1,2)*TU(2,1,I)
        GTU(1,2,I)=E2(1,1)*TU(1,2,I)+E2(1,2)*TU(2,2,I)
        GTU(2,1,I)=E2(2,1)*TU(1,1,I)+E2(2,2)*TU(2,1,I)
        GTU(2,2,I)=E2(2,1)*TU(1,2,I)+E2(2,2)*TU(2,2,I)
C
        E1(1,1)=TD(1,1,I)*GRU(1,1,I-1)+TD(1,2,I)*GRU(2,1,I-1)
        E1(1,2)=TD(1,1,I)*GRU(1,2,I-1)+TD(1,2,I)*GRU(2,2,I-1)
        E1(2,1)=TD(2,1,I)*GRU(1,1,I-1)+TD(2,2,I)*GRU(2,1,I-1)
        E1(2,2)=TD(2,1,I)*GRU(1,2,I-1)+TD(2,2,I)*GRU(2,2,I-1)
        E2(1,1)=E1(1,1)*GTU(1,1,I)+E1(1,2)*GTU(2,1,I)
        E2(1,2)=E1(1,1)*GTU(1,2,I)+E1(1,2)*GTU(2,2,I)
        E2(2,1)=E1(2,1)*GTU(1,1,I)+E1(2,2)*GTU(2,1,I)
        E2(2,2)=E1(2,1)*GTU(1,2,I)+E1(2,2)*GTU(2,2,I)
        GRU(1,1,I)=RU(1,1,I)+E2(1,1)
        GRU(1,2,I)=RU(1,2,I)+E2(1,2)
        GRU(2,1,I)=RU(2,1,I)+E2(2,1)
        GRU(2,2,I)=RU(2,2,I)+E2(2,2)
C
  100 CONTINUE
C
      GTD(1,1,NL-1)=TD(1,1,NL-1)
      GTD(1,2,NL-1)=TD(1,2,NL-1)
      GTD(2,1,NL-1)=TD(2,1,NL-1)
      GTD(2,2,NL-1)=TD(2,2,NL-1)
C
      GRD(1,1,NL-1)=RD(1,1,NL-1)
      GRD(1,2,NL-1)=RD(1,2,NL-1)
      GRD(2,1,NL-1)=RD(2,1,NL-1)
      GRD(2,2,NL-1)=RD(2,2,NL-1)
C
      DO 200 I=NL-2,LS,-1
C
        E1(1,1)=1.0-RU(1,1,I)*GRD(1,1,I+1)-RU(1,2,I)*GRD(2,1,I+1)
        E1(1,2)=   -RU(1,1,I)*GRD(1,2,I+1)-RU(1,2,I)*GRD(2,2,I+1)
        E1(2,1)=   -RU(2,1,I)*GRD(1,1,I+1)-RU(2,2,I)*GRD(2,1,I+1)
        E1(2,2)=1.0-RU(2,1,I)*GRD(1,2,I+1)-RU(2,2,I)*GRD(2,2,I+1)
        DT=E1(1,1)*E1(2,2)-E1(1,2)*E1(2,1)
        E2(1,1)= E1(2,2)/DT
        E2(1,2)=-E1(1,2)/DT
        E2(2,1)=-E1(2,1)/DT
        E2(2,2)= E1(1,1)/DT
        GTD(1,1,I)=E2(1,1)*TD(1,1,I)+E2(1,2)*TD(2,1,I)
        GTD(1,2,I)=E2(1,1)*TD(1,2,I)+E2(1,2)*TD(2,2,I)
        GTD(2,1,I)=E2(2,1)*TD(1,1,I)+E2(2,2)*TD(2,1,I)
        GTD(2,2,I)=E2(2,1)*TD(1,2,I)+E2(2,2)*TD(2,2,I)
C
        E1(1,1)=TU(1,1,I)*GRD(1,1,I+1)+TU(1,2,I)*GRD(2,1,I+1)
        E1(1,2)=TU(1,1,I)*GRD(1,2,I+1)+TU(1,2,I)*GRD(2,2,I+1)
        E1(2,1)=TU(2,1,I)*GRD(1,1,I+1)+TU(2,2,I)*GRD(2,1,I+1)
        E1(2,2)=TU(2,1,I)*GRD(1,2,I+1)+TU(2,2,I)*GRD(2,2,I+1)
        E2(1,1)=E1(1,1)*GTD(1,1,I)+E1(1,2)*GTD(2,1,I)
        E2(1,2)=E1(1,1)*GTD(1,2,I)+E1(1,2)*GTD(2,2,I)
        E2(2,1)=E1(2,1)*GTD(1,1,I)+E1(2,2)*GTD(2,1,I)
        E2(2,2)=E1(2,1)*GTD(1,2,I)+E1(2,2)*GTD(2,2,I)
        GRD(1,1,I)=RD(1,1,I)+E2(1,1)
        GRD(1,2,I)=RD(1,2,I)+E2(1,2)
        GRD(2,1,I)=RD(2,1,I)+E2(2,1)
        GRD(2,2,I)=RD(2,2,I)+E2(2,2)
C
  200 CONTINUE
C
      RETURN
      END
C
C *** P-SV MODIFIED R/T MATIX ***
C
      SUBROUTINE MDRTPSV(OM,WN)
C
      COMPLEX CMS,CMP,EA(4,4),EB(4,4),TD,TU,RD,RU
     *       ,DDA(2,2),DUB(2,2),DET,VP,VS
      COMMON /SOLY/LS,SDEP,LO,ODEP
     *    /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *    /MRTPSV/TD(2,2,0:20),TU(2,2,0:20),RD(2,2,0:20),RU(2,2,0:20)
C
C *** CHECK FOR THE DIMENSION OF COMMON ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM MDRTPSV: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** MODIFIED R/T MATRIX ***
C
      CALL MTXPSV(OM,WN,1,CMS,CMP,EA)
C
      IF(LS.EQ.1)THEN
        CALL DDUPSV(OM,WN,SDEP,CMS,CMP,DUB)
      ELSE
        CALL DDUPSV(OM,WN,THK(1),CMS,CMP,DUB)
      END IF
C
      DET=EA(3,1)*EA(4,2)-EA(3,2)*EA(4,1)
      RU(1,1,0)=-(DUB(1,1)*(EA(3,3)*EA(4,2)-EA(3,2)*EA(4,3))
     *           +DUB(2,1)*(EA(3,4)*EA(4,2)-EA(3,2)*EA(4,4)))/DET
      RU(1,2,0)=-(DUB(1,2)*(EA(3,3)*EA(4,2)-EA(3,2)*EA(4,3))
     *           +DUB(2,2)*(EA(3,4)*EA(4,2)-EA(3,2)*EA(4,4)))/DET
      RU(2,1,0)=-(DUB(1,1)*(EA(3,1)*EA(4,3)-EA(3,3)*EA(4,1))
     *           +DUB(2,1)*(EA(3,1)*EA(4,4)-EA(3,4)*EA(4,1)))/DET
      RU(2,2,0)=-(DUB(1,2)*(EA(3,1)*EA(4,3)-EA(3,3)*EA(4,1))
     *           +DUB(2,2)*(EA(3,1)*EA(4,4)-EA(3,4)*EA(4,1)))/DET
C
      IF(NL.EQ.1)RETURN
C
      IF(LS.EQ.1)THEN
        CALL DDUPSV(OM,WN,THK(1)-SDEP,CMS,CMP,DDA)
      ELSE
        CALL DDUPSV(OM,WN,THK(1),CMS,CMP,DDA)
      END IF
C
      DO 100 I=1, NL-1
C
        CALL MTXPSV(OM,WN,I+1,CMS,CMP,EB)
C
        IF(LS.EQ.(I+1))THEN
          CALL DDUPSV(OM,WN,SDEP,CMS,CMP,DUB)
        ELSE
          CALL DDUPSV(OM,WN,THK(I+1),CMS,CMP,DUB)
        END IF
C
        CALL MTRPSV(EA,EB,DDA,DUB,I) 
C
        DO 110 J=1,4
          DO 120 K=1,4
            EA(J,K)=EB(J,K)
  120     CONTINUE
  110   CONTINUE
C
        IF(LS.EQ.(I+1))THEN
          IF(LS.NE.NL)THEN
            CALL DDUPSV(OM,WN,THK(I+1)-SDEP,CMS,CMP,DDA)
          END IF
        ELSE
          CALL DDUPSV(OM,WN,THK(I+1),CMS,CMP,DDA)
        END IF
C
  100 CONTINUE
C
      RETURN
      END
C
C
C *** P-SV MODIFIED R/T MATRIX FOR Ith LAYER ***
C
        SUBROUTINE MTRPSV(EA,EB,DDA,DUB,L) 
C
      COMPLEX EA(4,4),EB(4,4),DDA(2,2),DUB(2,2),TD,TU,RD,RU
     *          ,E1(4,4),E2(4,4),E3(4,4),VP,VS
     * ,a1(4),a2(4),a3(4),b1(4),b2(4),b3(4)  
     * ,c1(4),c2(4),c3(4),d1(4),d2(4),d3(4)  
     * ,aa(4),EE(4,4)
      COMMON /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
     *      /MRTPSV/TD(2,2,0:20),TU(2,2,0:20),RD(2,2,0:20),RU(2,2,0:20)
C
C *** CHECK FOR THE DIMENSION OF COMMON ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM MTRPSV: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** MATRIX ***
C
      DO 100 I=1,2
        DO 110 J=1,2
          EE(I,J)= EB(I,J)
          EE(I,J+2)=-EA(I,J+2)
          EE(I+2,J)= EB(I+2,J)
          EE(I+2,J+2)=-EA(I+2,J+2)
          E2(I,J)= EA(I,J)
          E2(I,J+2)=-EB(I,J+2)
          E2(I+2,J)= EA(I+2,J)
          E2(I+2,J+2)=-EB(I+2,J+2)
  110   CONTINUE
  100 CONTINUE
C
C     * INVERSE MATRIX OF EE *
C
        DO 222 I=1,4
C
        IF(I.EQ.1)THEN
          J=2
          K=3
          M=4
        ELSE
          IF(I.EQ.2)THEN
            J=3
            K=4
            M=1
          ELSE
            IF(I.EQ.3)THEN
              J=4
              K=1
              M=2
            ELSE
              J=1
              K=2
              M=3
            END IF
          END IF
        END IF
C
        A1(I)=EE(I,4)*EE(J,1)-EE(I,1)*EE(J,4)  
        A2(I)=EE(I,4)*EE(J,2)-EE(I,2)*EE(J,4)  
        A3(I)=EE(I,4)*EE(J,3)-EE(I,3)*EE(J,4)  
        B1(I)=EE(I,3)*EE(J,2)-EE(I,2)*EE(J,3)  
        B2(I)=EE(I,1)*EE(J,3)-EE(I,3)*EE(J,1)  
        B3(I)=EE(I,2)*EE(J,1)-EE(I,1)*EE(J,2)  
        C1(I)=EE(K,3)*EE(M,2)-EE(K,2)*EE(M,3)  
        C2(I)=EE(K,1)*EE(M,3)-EE(K,3)*EE(M,1)  
        C3(I)=EE(K,2)*EE(M,1)-EE(K,1)*EE(M,2)  
        D1(I)=EE(K,4)*EE(M,1)-EE(K,1)*EE(M,4)  
        D2(I)=EE(K,4)*EE(M,2)-EE(K,2)*EE(M,4)  
        D3(I)=EE(K,4)*EE(M,3)-EE(K,3)*EE(M,4)  
C
        AA(I)=A1(I)*C1(I)+A2(I)*C2(I)+A3(I)*C3(I)
     *       +B1(I)*D1(I)+B2(I)*D2(I)+B3(I)*D3(I)
C
        E1(1,I)=(-EE(J,2)*D3(I)+EE(J,3)*D2(I)-EE(J,4)*C1(I))/AA(I)
        E1(2,I)=( EE(J,1)*D3(I)-EE(J,3)*D1(I)-EE(J,4)*C2(I))/AA(I)
        E1(3,I)=(-EE(J,1)*D2(I)+EE(J,2)*D1(I)-EE(J,4)*C3(I))/AA(I)
        E1(4,I)=( EE(J,1)*C1(I)+EE(J,2)*C2(I)+EE(J,3)*C3(I))/AA(I)
C
  222   CONTINUE
C
      DO 200 I=1,4
        DO 210 J=1,4
          E3(I,J)=(0.0,0.0)
          DO 220 K=1,4
            E3(I,J)=E3(I,J)+E1(I,K)*E2(K,J) 
  220     CONTINUE
  210   CONTINUE
  200 CONTINUE
C
      TD(1,1,L)=E3(1,1)*DDA(1,1)+E3(1,2)*DDA(2,1)  
      TD(2,1,L)=E3(2,1)*DDA(1,1)+E3(2,2)*DDA(2,1)  
      TD(1,2,L)=E3(1,1)*DDA(1,2)+E3(1,2)*DDA(2,2)  
      TD(2,2,L)=E3(2,1)*DDA(1,2)+E3(2,2)*DDA(2,2)  
      RD(1,1,L)=E3(3,1)*DDA(1,1)+E3(3,2)*DDA(2,1)  
      RD(2,1,L)=E3(4,1)*DDA(1,1)+E3(4,2)*DDA(2,1)  
      RD(1,2,L)=E3(3,1)*DDA(1,2)+E3(3,2)*DDA(2,2)  
      RD(2,2,L)=E3(4,1)*DDA(1,2)+E3(4,2)*DDA(2,2)  
C
      IF(L.EQ.NL)RETURN
C
      RU(1,1,L)=E3(1,3)*DUB(1,1)+E3(1,4)*DUB(2,1)  
      RU(2,1,L)=E3(2,3)*DUB(1,1)+E3(2,4)*DUB(2,1)  
      RU(1,2,L)=E3(1,3)*DUB(1,2)+E3(1,4)*DUB(2,2)  
      RU(2,2,L)=E3(2,3)*DUB(1,2)+E3(2,4)*DUB(2,2)  
      TU(1,1,L)=E3(3,3)*DUB(1,1)+E3(3,4)*DUB(2,1)  
      TU(2,1,L)=E3(4,3)*DUB(1,1)+E3(4,4)*DUB(2,1)  
      TU(1,2,L)=E3(3,3)*DUB(1,2)+E3(3,4)*DUB(2,2)  
      TU(2,2,L)=E3(4,3)*DUB(1,2)+E3(4,4)*DUB(2,2)  
C
      RETURN
      END
C
C
C *** P-SV ELEMENT MATIX ***
C
      SUBROUTINE MTXPSV(OM,WN,L,CMS,CMP,EE)
C
      COMPLEX VP,VS,VS2,WS2,CMS,VP2,WP2,CMP
     *      ,SM,EE(4,4),X0,AA,CMSG,CMPG
      COMMON /STRC/NL,DNS(20),VP(20),VS(20),THK(20)
C
C *** CHECK FOR THE DIMENSION OF COMMOM ***
C
      NC=20
      IF(NL.GT.NC)THEN
         WRITE(1,*)' FROM MTXPSV: NL.GT.NC !!!!!!!!!!!!!!!'
         STOP
      END IF
C
C *** ELEMENT MATRIX ***
C
      VS2=VS(L)*VS(L)
      VP2=VP(L)*VP(L)
      SM=DNS(L)*VS2
C
      IF(OM.EQ.0.0)THEN
C  
        X0=(1.0+VS2/VP2)/(1.0-VS2/VP2)
        AA=WN*SM
C
        EE(1,1)=(1.0,0.0)
        EE(1,2)=(1.0,0.0)
        EE(1,3)=(1.0,0.0)
        EE(1,4)=(1.0,0.0)
        EE(2,1)=-(X0-1.0)
        EE(2,2)=(1.0,0.0)
        EE(2,3)= X0-1.0
        EE(2,4)=(-1.0,0.0)
        EE(3,1)= (X0-3.0)*AA
        EE(3,2)= -2.0*AA
        EE(3,3)=-(X0-3.0)*AA
        EE(3,4)= 2.0*AA
        EE(4,1)= (X0-1.0)*AA
        EE(4,2)= -2.0*AA
        EE(4,3)= (X0-1.0)*AA
        EE(4,4)=-2.0*AA
C
      ELSE
C
        WN2=WN*WN
        OM2=OM*OM
C
        WS2=OM2/VS2
        CMS=CSQRT(WN2-WS2)
        IF(REAL(CMS).LT.0.0)CMS=-CMS
        CMSG=CMS/WN
C
        WP2=OM2/VP2
        CMP=CSQRT(WN2-WP2)
        IF(REAL(CMP).LT.0.0)CMP=-CMP
        CMPG=CMP/WN
C
        X0=2.0*WN-WS2/WN
C
        EE(1,1)=(-1.0,0.0)
        EE(1,2)= CMSG
        EE(1,3)=(-1.0,0.0)
        EE(1,4)= CMSG
        EE(2,1)=-CMPG
        EE(2,2)=(1.0,0.0)
        EE(2,3)= CMPG
        EE(2,4)=(-1.0,0.0)
        EE(3,1)= 2.0*SM*CMP 
        EE(3,2)=-SM*X0 
        EE(3,3)=-2.0*SM*CMP 
        EE(3,4)= SM*X0 
        EE(4,1)= SM*X0 
        EE(4,2)=-2.0*SM*CMS 
        EE(4,3)= SM*X0 
        EE(4,4)=-2.0*SM*CMS 
C
      END IF
C
      RETURN
      END
C
C
C *** P-SV UP/DOWN-GOING MATRIX ***
C
      SUBROUTINE DDUPSV(OM,WN,THK,CMS,CMP,DU)
C
      COMPLEX DU(2,2),CMS,CMP
C
      IF(OM.EQ.0.0)THEN
        EW=EXP(-WN*THK)
        DU(1,1)= EW
        DU(1,2)= (0.0,0.0)
        DU(2,1)= -WN*THK*EW
        DU(2,2)= EW
      ELSE
        DU(1,1)= CEXP(-CMP*THK)
        DU(1,2)= (0.0,0.0)
        DU(2,1)= (0.0,0.0)
        DU(2,2)= CEXP(-CMS*THK)
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE DCINV(A,N,M,N1,M1,EPS,DET,W,IP,NSTOP)
C
C                   MATRIX INVERSION BY SWEEP OUT METHOD.
C
C         * USAGE - -
C                CALL DCINV(A,N,M,N1,M1,EPS,DET,W,IP,NSTOP)
C           INPUT - -
C                A     C*16- 2-DIM. ARRAY CONTAINING THE COEFFICIENTS
C                            AND THE RIGHT-HAND SIDE VECTORS.
C                N     I*4 - ORDER OF MATRIX 'A'.
C                M     I*4 - NUMBER OF LINEAR EQUATIONS.
C                N1    I*4 - SIZE OF THE 2-DIM. ARRAY 'A' DEFINED
C                            IN 'DIMENSION' STATEMENT (FIRST INDEX).
C                M1    I*4 - SIZE OF THE 2-DIM. ARRAY 'A' DEFINED
C                            IN 'DIMENSION' STATEMENT (SECOND INDEX).
C                EPS   R*8 - PARAMETER TO CHECK SINGULARITY OF THE
C                            MATRIX 'A'. (STANDARD VALUE : 1.0D-14)
C           OUTPUT - -
C                A     C*16- INVERSE MATRIX AND SOLUTION.
C                NSTOP I*4 - FINAL STATE OF THE EXECUTION.
C                               0 : NORMAL END
C                               1 : MATRIX SINGULAR
C                               2 : ARGUMENT ERROR
C           WORKING AREA - -
C                W     C*16     1-DIM. ARRAY.
C      
      COMPLEX A,DET,PIVOT,W,AWK,PIVI
      REAL MAX
      DIMENSION A(N1,1),IP(1),W(1)
C
C     ARGUMENT CHECK.
C
      NM = N+M
C      IF ( N ) 1000,1000,100
      IF ( N .LE. 0 ) go to 1000
  100 CONTINUE
C      IF ( N-N1 ) 110,110,1000
      IF ( (N-N1) .GT. 0 ) go to 1000
  110 CONTINUE
C      IF ( M ) 1000,120,120
      IF ( M .LT. 0 ) go to 1000
  120 CONTINUE
C      IF ( NM-M1 ) 130,130,1000
      IF ( (NM-M1) .GT. 0 ) go to 1000
  130 CONTINUE
C      IF ( EPS ) 140,150,150
      IF ( EPS .GE. 0) go to 150
  140 CONTINUE
      EPS = 1.0D-14
  150 CONTINUE
C
C     INITIALIZATION.
C
      EPSS = 1.0D-2*EPS
      DET = 1.0D0
      DO 160 I=1,N
      IP(I) = 0
  160 CONTINUE
C
C     PIVOT SERCH.
C
      DO 270 K=1,N
      MAX = -1.0D0
      DO 190 I=1,N
C      IF ( IP(I) ) 170,170,190
      IF ( IP(I) .GT. 0 ) go to 190
  170 CONTINUE
      ABSS = CABS(A(I,K))
C      IF ( MAX-ABSS) 180,190,190
      IF ( (MAX-ABSS) .GE. 0) go to 190
  180 CONTINUE
      MAX = ABSS
      L = I
  190 CONTINUE
C
C     CHECK SINGULARITY AND CALCULATE DETERMINANT.
C
C      IF ( MAX-EPS ) 1010,1010,200
      IF ( (MAX-EPS) .LE. 0 ) goto 1010
  200 CONTINUE
      PIVOT = A(L,K)
      DET = DET*PIVOT
C
C     START SWEEP OUT.
C
      IP(L) = K
      PIVI = - 1.0D0/PIVOT
      DO 250 J=1,NM
C      IF ( J-K ) 210,250,210
      IF ( (J-K) .eq. 0 ) go to 250
  210 CONTINUE
      AWK = A(L,J)*PIVI
C      IF ( CABS(AWK)-EPSS ) 240,240,220
      IF ( (CABS(AWK)-EPSS) .LE. 0 ) go to 240
  220 CONTINUE
      DO 230 I=1,N
      A(I,J) = A(I,J) + A(I,K)*AWK
  230 CONTINUE
  240 CONTINUE
      A(L,J) = -AWK
  250 CONTINUE
      DO 260 I=1,N
      A(I,K) = A(I,K)*PIVI
  260 CONTINUE
      A(L,K) = -PIVI
  270 CONTINUE
C
C     EXCHANGE COLUMN.
C
      DO 290 J=1,NM
      DO 280 I=1,N
      W(I) = A(I,J)
  280 CONTINUE
      DO 290 I=1,N
      A(IP(I),J) = W(I)
  290 CONTINUE
C      IF ( N-1 ) 350,350,300
      IF ( (N-1) .LE. 0 ) go to 350
  300 CONTINUE
      DO 320 I=1,N
      DO 310 J=1,N
      W(J) = A(I,J)
  310 CONTINUE
      DO 320 J=1,N
      A(I,J) = W(IP(J))
  320 CONTINUE
      NM = N-1
      DO 340 I=1,NM
      K = I+1
      DO 340 J=K,N
C      IF ( IP(I)-IP(J) ) 340,340,330
      IF ( (IP(I)-IP(J)) .LE. 0 ) go to 340
  330 CONTINUE
      DET = -DET
  340 CONTINUE
  350 CONTINUE
      NSTOP = 0
      RETURN
C
C     ARGUMENT ERROR RETURN.
C
 1000 CONTINUE
      NSTOP = 3
      WRITE(10,10) N,M,N1,M1
      RETURN
C
C     MATRIX IS SINGULAR.
C
 1010 CONTINUE
      DET = 0.0D0
C      IF ( MAX ) 1011,1020,1011
      IF ( MAX .eq. 0) go to 1020
 1011 CONTINUE
      NSTOP = 2
      WRITE(10,20) K
      RETURN
 1020 CONTINUE
      NSTOP = 1
      WRITE(10,30)
      RETURN
   10 FORMAT(1H0,'(SUBR.DCINV) INVALID ARGUMENT. N,M,N1,M1 =',4I5)
   20 FORMAT(1H0,'(SUBR.DCINV) MATRIX IS SINGULAR AT STEP #',I5)
   30 FORMAT(1H0,'(SUBR.DCINV) MATRIX IS SINGULAR.')
      END
C
      SUBROUTINE DCLNLU(A,N,N1,B,EPS,W,IP,NSTOP)
C
C                   SOLUTION OF THE SIMULTANEOUS LINEAR EQUATIONS
C                  BY CROUT METHOD ( LU FACTORIZATION ).
C
C         * USAGE - -
C                CALL DCLNLU(A,N,N1,B,EPS,W,IP,NSTOP)
C           INPUT - -
C                A     C*16- 2-DIM. ARRAY CONTAINING THE COEFFICIENTS.
C                N     I*4 - ORDER OF THE MATRIX 'A'.
C                N1    I*4 - SIZE OF THE 2-DIM. ARRAY 'A' DEFINED
C                            IN 'DIMENSION' STATEMENT (FIRST INDEX).
C                B     C*16- 1-DIM. ARRAY CONTAINING THE RIGHT-HAND
C                            SIDE VECTOR.
C                EPS   R*8 - PARAMETER TO CHECK SINGULARITY OF THE
C                            MATRIX 'A'. (STANDARD VALUE : 1.0D-14)
C           OUTPUT -
C                A     C*16- RESULT OF THE LU FACTORIZATION.
C                B     C*16- SOLUTION.
C                NSTOP I*4 - FINAL STATE OF THE EXECUTION;
C                               0 : NORMAL END
C                               1 : MATRIX SINGULAR
C                               2 : ARGUMENT ERROR
C           WORKING AREA - -
C                IP    I*4 - 1-DIM. ARRAY.
C                W     C*16- 1-DIM. ARRAY.
C
      COMPLEX A,B,AWK,W
      REAL MAX
      DIMENSION A(N1,1),B(1),IP(1),W(1)
C
C     ARGUMENT CHECK.
C
      NM1 = N-1
C      IF ( N1-N ) 1010,100,100
      IF ( (N1-N) .LT. 0 ) goto 1010
  100 CONTINUE
C      IF ( NM1 ) 1010,1000,110
      IF ( NM1 .LT. 0 ) go to 1010
      IF ( NM1 .EQ. 0 ) go to 1000
  110 CONTINUE
C      IF ( EPS ) 120,130,130
      IF ( EPS .GE. 0 ) goto 130
  120 CONTINUE
      EPS = 1.0D-14
  130 CONTINUE
C
C     INITIALIZATION.
C
      DO 140 I=1,N
      W(I) = CABS(A(I,1))
      IP(I) = I
  140 CONTINUE
C
C     FIND MAXIMUM ELEMENT FOR EVERY ROW.
C
      DO 160 J=2,N
      DO 160 I=1,N
      ABSS = CABS(A(I,J))
      WRK = W(I)
C      IF ( WRK-ABSS ) 150,160,160
      IF ( (WRK-ABSS) .GE. 0 ) goto 160
  150 CONTINUE
      W(I) = ABSS
  160 CONTINUE
      DO 180 I=1,N
      WRK = W(I)
C      IF ( WRK) 170,1020,170
      IF ( WRK  .eq. 0) go to 1020
  170 CONTINUE
      W(I) = 1.0D0/W(I)
  180 CONTINUE
C
C     START LU FACTORIZATION.
C
      DO 260 K=1,N
      K1 = K-1
C      IF ( K1) 190,210,190
      IF ( K1 .eq. 0 ) go to 210
  190 CONTINUE
      DO 200 J=1,K1
      IROW = IP(J)
      AWK       = - A(IROW,K) * A(IROW,J)
      A(IROW,K) = - AWK
      KK = J+1
      DO 200 II=KK,N
      I = IP(II)
      A(I,K) = A(I,K) + A(I,J)*AWK
  200 CONTINUE
C
C     FIND MAXIMUM ELEMENT IN THE K-TH COLUMN.
C
  210 CONTINUE
      MAX = 0.0D0
      DO 230 II=K,N
      I = IP(II)
      WRK = CABS(A(I,K))*W(I)
C      IF ( MAX-WRK ) 220,230,230
      IF ( (MAX-WRK) .GE. 0 ) go to 230
  220 CONTINUE
      IIROW = II
      MAX = WRK
  230 CONTINUE
C
C     CHECK SINGULARITY.
C
C      IF ( MAX-EPS ) 240,240,250
      IF ( (MAX-EPS) .GT. 0 )  go to 250
  240 CONTINUE
C      IF ( MAX ) 1030,1020,1030
      IF ( MAX .EQ. 0) go to 1020
      go to 1030
  250 CONTINUE
      IROW = IP(IIROW)
      IP(IIROW) = IP(K)
      IP(K) = IROW
      A(IROW,K) = 1.0D0/A(IROW,K)
  260 CONTINUE

C      ENTRY DCLSUB(B)
C      IF ( NM1 ) 1010,1000,270
      IF ( NM1 .LT. 0 ) go to 1010
      IF ( NM1 .EQ. 0 ) go to 1000
      IF ( NM1 .GT. 0 ) go to 270

C
C     FORWARD SUBSTITUTION.
C
  270 CONTINUE
      DO 280 K=1,NM1
      IROW = IP(K)
      AWK = -B(IROW)*A(IROW,K)
      B(IROW) = -AWK
      K1 = K+1
      DO 280 II=K1,N
      I = IP(II)
      B(I) = A(I,K)*AWK+B(I)
  280 CONTINUE
      B(I) = B(I)*A(I,N)
C
C     BACKWARD SUBSTITUTION.
C
      DO 290 KK=2,N
      K = N-KK+2
      AWK = -B(I)
      K1 = K-1
      DO 290 II=1,K1
      I = IP(II)
      B(I) = A(I,K)*AWK+B(I)
  290 CONTINUE
      DO 300 K=1,N
      W(K) = B(K)
  300 CONTINUE
      DO 310 K=1,N
      I = IP(K)
      B(K) = W(I)
  310 CONTINUE
      NSTOP = 0
      RETURN
C
C     MATRIX ELEMENT IS ONLY ONE.
C
 1000 CONTINUE
C      IF ( CABS(A(1,1)) ) 1001,1020,1001
      IF ( (CABS(A(1,1)) .eq. 0) ) go to 1020
 1001 CONTINUE
      NSTOP = 0
      B(1) = B(1)/A(1,1)
      IP(1) = 1
      RETURN
C
C     ARGUMENT ERROR RETURN.
C
 1010 CONTINUE
      WRITE(10,10) N,N1
      NSTOP = 3
      RETURN
C
C     MATRIX IS SINGULAR.
C
 1020 CONTINUE
      WRITE(10,20)
      NSTOP = 1
      RETURN
 1030 CONTINUE
      WRITE(10,30) K
      NSTOP = 2
      RETURN
   10 FORMAT(1H0,'(SUBR.DCLNLU) INVALID ARGUMENT. N,N1 =',2I5)
   20 FORMAT(1H0,'(SUBR.DCLNLU) MATRIX IS SINGULAR.')
   30 FORMAT(1H0,'(SUBR.DCLNLU) MATRIX IS SINGULAR AT STEP #',I4)
      END
C
C *** THE BESSEL FUNCTION OF ORDER 0 ***
C
      REAL FUNCTION BSJ0(X)
C
      DATA C3,C5,C7,C9
     *   /   4.0310 96038 59       E-5,
     *       7.9012 34182 8039     E-3,
     *      4.4444 44444 25769 5  E-1,
     *       3.9999 99999 99989 66 E 0 /

      DATA D5,D7,D8,D11,D12
     *   /  2.1332 90985 8        E- 7,
     *       1.1202 21502 384      E- 5,
     *      2.5202 11970 18629    E- 3, 
     *       5.6040 47189 80261 6  E- 2,
     *      3.2757 91375 91465 09 E- 1 /

      DATA E6,E7,E10,E11,E13,E14
     *   / 
     *      5.6607 46146 93       E- 6,  1.7226 12595 802   E- 5,
     *      1.1790 12935 71024 6  E- 2,  6.3961 29897 84324 E- 3,
     *       4.6828 23482 34590 E- 3,
     *      3.0007 92705 19555 60 E- 1                            /

      DATA A6,A8,A10
     *   / 
     *      2.8872 15007 2         E- 7,
     *      2.1846 78334 973       E- 5,
     *      0.7978 84560 80286 526 E  0                         /

      DATA B5,B7,B9,B11
     *   /  1.3089 75220 0       E- 7,
     *      4.0856 34631 8    E-7,
     *      5.2586 51475 08   E-6,
     *       9.1310 64157 0497 E-4 /

      DATA PI4  / 0.78539 81633 97448 31 /

      C2 = -1.9891 96578 6        E-6
      C4 = -6.4499 78225 950      E-4
      C6 = -7.1111 11100 46304    E-2
      C8 = -1.7777 77777 77584 46 E 0
      C10 =-3.9999 99999 99999 78 E 0 

      D6 = -5.3795 00918 201      E- 5
      D9 = -1.7073 87596 90737    E- 3
      D10 =-5.6148 69347 44975 4  E- 2
      D13 = -1.7759 67713 14338 34 E- 1

      E5 = -2.5797 89310 5        E- 7
      E8 =  -3.5284 91002 3231     E- 4
      E9 =   -5.9314 89738 8202  E- 4
      E12 =  -1.5037 41226 51373 90 E- 1

      A5 = -8.0992 84883           E- 8
      A7 =  -1.7424 98968 02   E-6
      A9 =  -8.7658 21590 6110 E-4
    
      B6 =  -2.0632 29204 9       E- 7
      B8 =   -1.1593 30628 42      E- 6
      B10 = -4.4239 73781 374     E- 5
      B12 = -9.9735 57010 03581 5 E- 2  

C 
      AX=ABS(X)
      IF (AX .GE. 1.0E12) GO TO 40
      IF (AX .GE. 8.0) GO TO 30
      IF (AX .GE. 6.0) GO TO 20
      IF (AX .GE. 4.0) GO TO 10
C
C     !X! < 4
C
      Z=(X*0.25)**2
      BSJ0=((((((((C2*Z+ C3)*Z +C4)*Z +C5)*Z +C6)*Z
     *       +C7)*Z +C8)*Z +C9)*Z +C10)*Z +1.0
      GO TO 9999
C
C     4 <= !X! < 6
C
   10 Z=AX-5.0
      BSJ0=(((((((D5*Z+D6)*Z+D7)*Z+D8)*Z+D9)*Z+D10)*Z
     *     +D11)*Z+D12)*Z+D13
      GO TO 9999
C
C     6 <= !X! < 8
C
   20 Z=AX-7.0
      BSJ0=((((((((E5*Z+E6)*Z +E7)*Z +E8)*Z +E9)*Z +E10)*Z +E11)*Z
     *       +E12)*Z +E13)*Z +E14
      GO TO 9999
C
C     8 <= !X! < 1.0E12
C
   30 Z=(8.0/AX)**2
      A=((((A5*Z +A6)*Z +A7)*Z +A8)*Z +A9)*Z +A10
      B=(((((((B5*Z +B6)*Z
     *  +B7)*Z +B8)*Z +B9)*Z +B10)*Z +B11)*Z +B12) /AX
      Q=AX-PI4
      BSJ0=(A*COS(Q) - B*SIN(Q)) /SQRT(AX)
      GO TO 9999
C
C     PARAMETER ERROR
C
   40 BSJ0=0.0
C
 9999 RETURN
      END
C
C
C *** THE BESSEL FUNCTION OF ORDER ONE ***
C
      REAL FUNCTION BSJ1(X)
C
      DATA C2,C4,C6,C8
     *   /  8.9514 96872 0        E-6, 
     *      2.2574 92590 3842     E-3, 
     *      1.7777 77775 58267 6  E-1,
     *      2.6666 66666 66491 50 E 0 /

      DATA D5,D8,D11,D12
     *   /  4.8857 13666          E- 8,
     *      3.7656 50660 9458     E- 4,
     *       6.8295 50387 40438    E- 3,
     *      1.6844 60804 23507 80 E- 1 / 


      DATA E5,E6,E9,E10,E13
     *   /  5.7071 42412 9       E- 7,
     *      2.3218 13149 97      E- 6, 
     *       2.1170 94601 37864    E- 3,
     *      2.9657 44869 54234   E- 3, 
     *       3.0074 82453 02747 75 E- 1 /

      DATA A5,A7,A9,A10
     *   /  8.9550 40706          E- 8,
     *       2.0593 18935 93    E-6,
     *       1.4609 70265 11633 E-3,
     *      7.9788 45608 02865 46 E- 1                          /

      DATA B6,B8,B10,B12
     *   / 
     *      2.2297 66956 2        E- 7, 
     *      1.2957 31867 99       E- 6, 
     *      5.4070 79074 732      E- 5, 
     *      2.9920 67103 01074 48 E- 1                          /
      DATA PI4  / 0.78539 81633 97448 31 /
     
      B5 = -1.4024 48404 3        E- 7
      B7 = -4.4752 03358 4     E-7
      B9 = -6.0676 75972 38    E-6
      B11 = -1.2783 48981 98997 E-3

      C3 = -1.6124 40490 740      E-4
      C5 = -2.3703 70267 63209    E-2
      C7 =  -8.8888 88888 61512 4  E-1
      C9 =  -3.9999 99999 99995 63 E 0 

      D6 = -6.1029 92681 89       E- 6
      D7 =  -1.7066 40506 78       E- 6
      D9 =  -6.7213 28811 703      E- 5 
      D10 = -1.2601 05985 12045 4  E- 2
      D13 = -1.1208 09437 96045 28 E- 1
      D14 =  -3.2757 91375 91465 22 E- 1

      E7 = -4.5285 96911 743      E- 5
      E8 = -1.2058 28825 8765    E- 4
      E11 = -4.7160 51742 84081 7  E- 2
      E12 = -1.9188 38969 35370 8 E- 2
      E14 =-4.6828 23482 34583   E- 3   

      A6 = -3.2722 78326 5        E- 7
      A8 = -2.8088 72167 333      E- 5

C
      AX=ABS(X)
      IF (AX .GE. 1.0E12) GO TO 50
      IF (AX .GE. 8.0) GO TO 30
      IF (AX .GE. 6.0) GO TO 20
      IF (AX .GE. 4.0) GO TO 10
C
C     !X! < 4
C
      Y=X*0.25
      Z=Y*Y
      BSJ1=((((((((C2*Z+ C3)*Z +C4)*Z +C5)*Z +C6)*Z
     *       +C7)*Z +C8)*Z +C9)*Z +2.0) *Y
      GO TO 9999
C
C     4 <= !X! < 6
C
   10 Z=AX-5.0
      BSJ1=((((((((D5*Z +D6)*Z +D7)*Z +D8)*Z +D9)*Z +D10)*Z +D11)*Z
     *       +D12)*Z +D13)*Z +D14
      GO TO 40
C
C     6 <= !X! < 8
C
   20 Z=AX-7.0
      BSJ1=((((((((E5*Z +E6)*Z +E7)*Z +E8)*Z +E9)*Z +E10)*Z +E11)*Z
     *       +E12)*Z +E13)*Z +E14
      GO TO 40
C
C     8 <= !X! < 1.0E12
C
   30 Z=(8.0/AX)**2
      A=((((A5*Z +A6)*Z +A7)*Z +A8)*Z +A9)*Z +A10
      B=(((((((B5*Z +B6)*Z
     *  +B7)*Z +B8)*Z +B9)*Z +B10)*Z +B11)*Z +B12) /AX
      Q=AX-PI4
      BSJ1=(A*SIN(Q) + B*COS(Q)) /SQRT(AX)
   40 IF (X .LT. 0.0) BSJ1=-BSJ1
      GO TO 9999
C
C     PARAMETER ERROR
C
   50 BSJ1=0.0
C
 9999 RETURN
      END
