c 
c *** This code computes strong ground motions using theoretical Green's functions
c     considering static offsets of surface faulting.
c *** You must run "phs3sQ.f" to get the normal modes before running this code. 
c *** You can get waveforms using fft program "grfftsp.f"
c *** You can plot waves and Fourier amplitudes using "waveVDs.m" of a Matlab m-file. 
C *** FOR BUGS OR COMMENTS, PLEASE E-MAIL to "hisada@cc.kogakuin.ac.jp", 
C     OR MAIL TO "Yoshiaki Hisada, Dept. of Architecture, Kogakuin Univeristy
C     Nishi-Shinjuku 1-24-2, Tokyo 163-8677, Japan" 
c
c     References: 
c     For Green's Function of Layered Half-Spaces
C       1) HISADA, Bull. Seismo. Soc. Am., V.84, Oct. 1994, (Part 1) 
C       2) HISADA, Bull. Seismo. Soc. Am., V.85, Aug. 1995, (Part 2) 
C       3) HISADA, Bull. Seismo. Soc. Am., V.85, Oct. 1995, (comments) 
c     For Method to Simulate Near-Fault Strong Ground Motions
C       4) HISADA and Bielak, Bull. Seismo. Soc. Am., Vo.93,.No.3, 2003
C 
C    (Originally made in 1992, and modified in 2003) 
c 
c * Parameters :  
c     MOM : Number of Omega 
c     MOB : NUmber of Observation Points 
c 
      PROGRAM grflt12sx
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      PARAMETER(MOM=531,MOB=51) 
      COMPLEX*16 GXs(MOM,MOB),GYs(MOM,MOB),GZs(MOM,MOB),SMOs(MOM,15) 
      COMPLEX*16 GX(MOM,MOB),GY(MOM,MOB),GZ(MOM,MOB) 
C 
      WRITE(*,*) 
      WRITE(*,*) 
      WRITE(*,*)'grflt12sx.f computes strong ground motions including'
      WRITE(*,*)' the effects of surface fault and the freq-dependent Q' 
      write(*,*)' (Originally made in 1992, and modified in 2005)'
      write(*,*) 
      WRITE(*,*)'"grflt12sx-in.csv" is the input data'
      WRITE(*,*)' Please Check "fort.10" for troubles.' 
      WRITE(*,*) 
     *' For questions, e-mail to "hisada@cc.kogakuin.ac.jp".' 
      WRITE(*,*)' This code is open for the academic use.' 
      WRITE(*,*) 
     *' You must run "phs3sQx.f" before running this code !!'
C 
      do io=1,mom
        do iob=1,mob
            GXs(io,iob)=(0.d0,0.d0)
            GYs(io,iob)=(0.d0,0.d0)
            GZs(io,iob)=(0.d0,0.d0)
        end do
      end do
c
      CALL INDAT(MOM,MOB)
      CALL PHSBRC(MOM) 
      write(*,*) 
      write(*,*) 
      write(*,*)'Skip computation of static terms?' 
      write(*,*)'  Enter 0 for NO  (Exact, but slow. Use for surface fau
     *lt)' 
      write(*,*)'  Enter 1 for YES (Fast, but approximate. Effective for
     * burined fault)' 
      read(*,*)iskips
      if(iskips.eq.0)CALL HKQVWs(MOM,MOB,SMOs,GXs,GYs,GZs)
c
      WRITE(*,*) 
      WRITE(*,*) 
      write(*,*)'Skip computation of dynamic terms?' 
      write(*,*)'  Enter 0 for NO  (Use for normal condition)' 
      write(*,*)'  Enter 1 for YES (Use, when output static terms only)' 
      read(*,*)iskipd 
      if(iskipd.ne.0)then
        do io=1,mom 
          do iob=1,mob 
            GX(io,iob)=GXs(io,iob) 
            GY(io,iob)=GYs(io,iob) 
            GZ(io,iob)=GZs(io,iob) 
          end do 
        end do 
      else 
        CALL HKQVWd(MOM,MOB,GXs,GYs,GZs,GX,GY,GZ) 
      end if 
c 
      CALL OTDAT(MOM,MOB,GX,GY,GZ) 
c 
      WRITE(*,*) 
      WRITE(*,*)' Use "grfftspx.f" for FFT'
      WRITE(*,*)' Use "waveVDs.m" for Plotting' 
C 
      STOP 
      END
C 
c 
C *** DATA INPUT *** 
C 
      SUBROUTINE INDAT(MOM,MOB) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMMON /FREQ/DOM,IOM,NOM,OMI /OBS/XO(51),YO(51),ZO(51),NOB 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     *    /INTG/VPMAX,VSMAX,RYMIN,CFINAL,N11,N12,M11 
     *    /FLT/STR,DIP,RAK(203,15),FL,FW,VR,FD(203,15),RT(2,15),TWI 
     *        ,xflt,yflt,zflt,delay 
     *    /IFLT/NF,NTW,IS,ngauss,ndip,nstr,iramp 
     *    /Hypo/xhypo,yhypo,zhypo /outom/ioutom 
     *    /SIGN/ISIGN /OTST/IOT,IST 
     *    /WVNUMs/WNRs(3),NWN1o,NWN2o,NWN1,NWN2,NWT1,NWT2 
      character infile*20
c 
C *** PARAMETERS IN COMMOM STATEMENT *** 
C 
      NML =20 
      NMOB=51 
      NFLT=203 
      IF(MOB.LT.NMOB)NMOB=MOB 
C 
C *** OMEGA DATA *** 
C 
      write(*,*) 
      write(*,*)'Data from INDAT (For More Detail, Please see fort.10)' 
      write(*,*) 
      write(*,*)'Enter Input File Name for "grflt12sx1-in.csv"'
      read(*,'(a20)')infile
      OPEN (UNIT=7,FILE=infile,STATUS='OLD')
c     OPEN (UNIT=7,FILE='grflt12sx1-in.csv',STATUS='OLD')
C
      pi2=datan(1.d0)*8.d0
      read(7,*)
      read(7,*)
      read(7,*)dt,nt
      write(*,*)'dt,nt=',dt,nt
      read(7,*)
      read(7,*)period,OMI
c      write(*,*)'period,OMI=',period,OMI
      duration=dt*nt
      dom=datan(1.d0)*8.d0/duration 
      iom=1 
      nom=int(duration/period)
c
      WRITE(10,*)'FROM INDATA:' 
      WRITE(10,*) 
      WRITE(*,1130)nt,dt,period 
      WRITE(*,1140)NOM,DOM,OMI 
      WRITE(10,1130)nt,dt,period 
      WRITE(10,1140)NOM,DOM,OMI 
 1130 format(/' Num. of Time, Delta Time and Min. Period (s)=',i5,2f8.4) 
 1140 format( ' Num. of Omega, dOM, and Imag OM (rad/sec) =',i5,2f10.7) 
C 
      IF((NOM+1).GT.MOM)THEN 
        WRITE(10,*)' NOM+1 > MOM !!!!!!!!!!!!!' 
        STOP 
      END IF 
C 
C *** MEDIUM DATA *** 
C 
      read(7,*)
      read(7,*)
      READ(7,*)NL
      if(NML.lt.NL)then
        write(10,*)'from Indat:'
        WRITE(10,*)' NC < NL !!!!!!!!!!!!!'
        write(*,*)'from Indat:'
        WRITE(*,*)' NC < NL !!!!!!!!!!!!!'
        STOP
      END IF
      read(7,*)
C
      WRITE(*,2200)NL
      WRITE(10,2200)NL
      DO 140 L=1,NL 
        READ(7,*)i,DNS(L),VP(L),QP(L),FP(L),VS(L),QS(L),FS(L),THK(L)
        WRITE(*,2210)i,DNS(L),VP(L),QP(L),FP(L),VS(L),QS(L),FS(L),THK(L)
       WRITE(10,2210)L,DNS(L),VP(L),QP(L),FP(L),VS(L),QS(L),FS(L),THK(L)
  140 CONTINUE 
 2200 FORMAT(/' Total Number of Layers =',I5, 
     *       /' Layer,Density,Vp(m/s),   Qp  ,   Fp  ', 
     *        ',Vs(m/s),   Qs  ,   Fs  , Thick(m)') 
 2210 FORMAT(I5,F9.2,7F8.1,F15.2) 
C 
      IF(NL.GT.NML)THEN 
        WRITE(10,*)' NL>NML !!!!!!!!!!!!!' 
        STOP 
      END IF 
C 
C *** MAX Vs and Vp and MIN Rayleigh Phase Velocity *** 
C 
      VSMAX=VS(NL) 
      VPMAX=VP(NL) 
      VSMIN=VS(1) 
      MINVS=1 
      DO 160 IL=1,NL 
        IF(VS(IL).GT.VSMAX)VSMAX=VS(IL) 
        IF(VP(IL).GT.VPMAX)VPMAX=VP(IL) 
        IF(VS(IL).LT.VSMIN)THEN 
          VSMIN=VS(IL) 
          MINVS=IL 
        END IF 
  160 CONTINUE 
      RYMIN=FRHF(VP(MINVS),VS(MINVS)) 
C 
      WRITE(10,2250)VSMAX 
      WRITE(10,2260)VPMAX 
      WRITE(10,2270)RYMIN 
 2250 FORMAT(/'    Max Vs (m/sec)              =',f10.3) 
 2260 FORMAT( '    Max Vp (m/sec)              =',f10.3) 
 2270 FORMAT( '    Min Rayleigh Phase Velocity =',f10.3) 
C 
C *** FAULT DATA *** 
C 
      read(7,*)
      read(7,*)
      READ(7,*)SLENGTH,DWIDTH,NSTR,NDIP,ngauss
c      write(*,*)
c      write(*,*)'LENGTH,WIDTH=',SLENGTH,DWIDTH
c      write(*,*)'NSTR,NDIP,ngauss=',NSTR,NDIP,ngauss
      NF=NSTR*NDIP
      IF(NF.GT.NFLT)THEN
        write(10,*)'from Indat:'
        WRITE(10,*)' NF.GT.NFLT !!!!!!'
        write(*,*)'from Indat:'
        WRITE(*,*)' NF.GT.NFLT !!!!!!'
        STOP
      END IF
      if(ngauss.gt.6)then
        write(10,*)' ngauss > 6 !!!' 
        stop 
      end if 
      fl=slength/nstr 
      fw=dwidth/ndip 
      read(7,*)
      READ(7,*)DELAY,STR,DIP,VR
c      write(*,*)'Time Delay (s),Vr(m/s)=',DELAY,Vr
c      write(*,*)'Strike and Dip Angles (deg)=',STR,DIP
      str=str*pi2/360.d0
      dip=dip*pi2 /360.d0
      read(7,*)
      READ(7,*)XHYPO,YHYPO,ZHYPO
c      write(*,*)'Hypocenter (X,Y,Z)=',XHYPO,YHYPO,ZHYPO
      read(7,*)
      READ(7,*)xflt,yflt,zflt
c      write(*,*)'Fault Origin (X,Y,Z)=',xflt,yflt,zflt

      read(7,*)
      READ(7,*)NTW,TWI,IRAMP
c      write(*,*)'Number of Time Windows =',NTW
c      write(*,*)'Time Window Interval (s) =',TWI
c      write(*,*)'Slip Function Type =',Iramp
      if(ntw.gt.15)then
         write(*,*)'ntw > 15 !!!' 
         stop 
      end if 

      read(7,*)
c      write(*,*)
c      write(*,*)'Time Window Data (s):'
      do i=1,NTW
        READ(7,*)jj,RT(1,i),RT(2,i)
        if(jj.ne.i)write(*,*)'jj.ne.i: RT !!!'
        write(*,*)'i,RT(1,i),RT(2,i)',jj,RT(1,i),RT(2,i)
      end do 

      read(7,*) 
      read(7,*)isptn
      write(*,*)
      write(*,*)'Slip and Rake Data: Pattern =',isptn
c
      if(isptn.eq.1)then
c        write(*,*)
c        write(*,*)'Slip Data (m):'
        read(7,*)
        do j=1,NF
          READ(7,*)jj,(FD(j,i),i=1,NTW)
          if(jj.ne.j)write(*,*)'jj.ne.j: FD !!!'
c          write(*,*)'j,FD(j,i)',jj,(FD(j,i),i=1,NTW)
        end do
c
c        write(*,*)
c        write(*,*)'Rake Angle Data (deg):'
        read(7,*)
        do j=1,NF
          READ(7,*)jj,(rak(j,i),i=1,NTW)
          if(jj.ne.j)write(*,*)'jj.ne.j: Rak !!!'
c          write(*,*)'j,rak(j,i)',jj,(rak(j,i),i=1,NTW)
          do i=1,ntw
            rak(j,i)=rak(j,i)*pi2/360.d0
          end do
        end do
c
      else
c
        do 170 itw=1,NTW
          write(*,*)'Slip Data (m):'
          read(7,*)
          read(7,*)
          do j=ndip,1,-1
            read(7,*)k,(FD(nstr*(j-1)+i,itw),i=1,nstr)
            write(1,*)k,(FD(nstr*(j-1)+i,itw),i=1,nstr)
          end do
          write(*,*)'Rake Angle Data:'
          read(7,*)
          do j=ndip,1,-1
            read(7,*)k,(rak(nstr*(j-1)+i,itw),i=1,nstr)
            write(2,*)k,(rak(nstr*(j-1)+i,itw),i=1,nstr)
          end do
  170   continue
        do j=1,NF
          do i=1,ntw
            rak(j,i)=rak(j,i)*pi2/360.d0
          end do
        end do
c
      end if
C
      WRITE(*,2300)NSTR,NDIP,IRAMP 
      WRITE(*,2305)STR,DIP 
      WRITE(*,2315)slength,dwidth 
      WRITE(*,2320)FL,FW 
      write(*,2325)xflt,yflt,zflt 
      WRITE(*,2330)XHYPO,YHYPO,ZHYPO,VR 
      WRITE(*,2335)ntw,twi 
      WRITE(*,2340)ngauss,ngauss*ngauss 

      WRITE(10,2300)NSTR,NDIP,IRAMP 
      WRITE(10,2305)STR,DIP 
      WRITE(10,2315)slength,dwidth 
      WRITE(10,2320)FL,FW 
      write(10,2325)xflt,yflt,zflt 
      WRITE(10,2330)XHYPO,YHYPO,ZHYPO,VR 
      WRITE(10,2335)ntw,twi 
      WRITE(10,2340)ngauss,ngauss*ngauss 
      do i=1,ntw 
        WRITE(*,2345)i,RT(1,i),RT(2,i) 
        WRITE(10,2345)i,RT(1,i),RT(2,i) 
      end do 
c
 2300 FORMAT(/' Seismic Fault Data :',  
     * /'  Numbers of Sub-Faults along Strike and Dip =',2I5, 
     * /'  Ramp Func.=',I3,' (0: Ramp; 1: Smooth Ramp; 2: Exponential)')
 2305 FORMAT( '  Strike Angle(rd)=',F12.8,',  Dip Angle   (rd)=',F12.8) 
 2315 FORMAT( '  Fault Length (m)=',F12.3,',  Width(m)        =',F12.3) 
 2320 FORMAT( '  Sub-Length   (m)=',F12.3,',  Sub-Width(m)    =',F12.3) 
 2325 FORMAT( '  X Fault Edge (m)=',F12.3,',  Y Fault Edge (m)=',F12.3, 
     *       /'  Z Fault Edge (m)=',F12.3) 
 2330 FORMAT( '  Hypocenter X (m)=',F12.3,',  Hypocenter Y (m)=',F12.3,
     *       /'  Hypocenter Z (m)=',F12.3,',  Rupture Vel(m/s)=',F12.3) 
 2335 FORMAT( '  Num. of Time Windows=',i5,', Interval (sec)  =',F12.4) 
 2340 FORMAT( '  Max Num. of Gauss Points along one direction =',i5/ 
     *       ,'  Max Num. of Guass Points per Sub-Faults      =',i5) 
 2345 FORMAT( '  Time Window=',i3,', Half Rise-Time 1 & 2 (s) =',2F10.3) 
c       
      II=0 
      DO 270 I=1,NDIP 
      DO 270 J=1,NSTR 
      II=II+1 
      WRITE(10,2350)II,I,J 
      WRITE(10,2355)(FD(ii,k),k=1,ntw) 
      WRITE(10,2356)(rak(ii,k),k=1,ntw) 
  270 CONTINUE 
 2350 FORMAT(/'   Source Number   =',I4,' (',I2,',',I2,')') 
 2355 FORMAT( '   Dislocation for Each Time Windows (m)=',6F9.3)  
 2356 FORMAT( '   Rake Ang. for Each Time Windows (rad)=',6F9.5)  
c 
C *** NUMERICAL INTEGRAL DATA *** 
C 
      read(7,*)
      read(7,*)
      READ(7,*)WNRs(2),NWN1o
c      write(*,*)WNRs(2),NWN1o
      WNRs(1)=WNRs(2)/100000.0d0 
      read(7,*)
      READ(7,*)WNRs(3),NWN2o
c      write(*,*)WNRs(3),NWN2o
C
      WRITE(10,2400) 
      WRITE(10,2410)WNRs(1),WNRs(2) 
      WRITE(10,2420)0.0,WNRs(3) 
      WRITE(10,2430)NWN1o,NWN2o 
 2400 FORMAT(//' Static Wavenum. Integ. Data for Greenfield Method:') 
 2410 FORMAT( /' The first integ. range of w*k on real axis   =',2e12.4) 
 2420 FORMAT(  ' The second integ. range of w*k on imag. axis =',2e12.4) 
 2430 FORMAT(  ' Initial Integ. Num. of Adaptive Newton-Cotes =',2I12) 
C 
      read(7,*)
      read(7,*)
      READ(7,*)N11
      read(7,*)
      READ(7,*)N12
      read(7,*)
      READ(7,*)cfac
c      write(*,*)N11,N12,cfac
      CFINAL=rymin/cfac
C
      WRITE(10,2450) 
      WRITE(10,2460)N11 
      WRITE(10,2470)N12 
      WRITE(10,2480)CFINAL 
      WRITE(10,2490)2*(N11+N12)+1 
 2450 FORMAT(//' Number of Points for Numerical Integrations:') 
 2460 FORMAT( /'   From 0              to 1.2*om/Ray(min) =',I5) 
 2470 FORMAT(  '   From 1.2*om/Ry(min) to om/C(final)     =',I5) 
 2480 FORMAT(  '   C(final = Minimun Rayleigh Phase Vel.) =',F10.3) 
 2490 FORMAT(  '   Initial Number of Points: 2*(N1+N2)+1  =',I5) 
C
C *** CHANGE OF SIGNS FOR IMAGINARY PARTS ***
C
      read(7,*)
      read(7,*)
      READ(7,*)ISIGN
c      write(*,*)ISIGN
      IF(ISIGN.EQ.1)WRITE(10,2700)
      IF(ISIGN.EQ.0)WRITE(10,2710)
 2700 FORMAT(/' SIGNS OF IMAGINARY PARTS FOR RESULTS ARE CHANGED')
 2710 FORMAT(/' SIGNS OF IMAGINARY PARTS FOR RESULTS ARE NOT CHANGED')
C
C *** OP DATA ***
C
      read(7,*)
      read(7,*)
      READ(7,*)NOB
c      write(*,*)NOB
      WRITE(10,2800)NOB
 2800 FORMAT(//' TOTAL NUMBER OF OBSERVATION POINTS =',I6/)
C
      IF(NOB.GT.MOB)THEN
        WRITE(10,*)' NOB>NMOB !!!!!!!!!!!!!'
        STOP
      END IF
C
      read(7,*)
      DO 300 I=1,NOB
        READ(7,*)j,XO(I),YO(I),ZO(I)
c        write(*,*)j,XO(I),YO(I),ZO(I)
        WRITE(10,2820)I,XO(I),YO(I),ZO(I)
  300 CONTINUE
 2820 FORMAT('   OB NUM.=',I5,',     (X,Y,Z) =',3F12.4)
C
      CLOSE(UNIT=7)
C
c *** output of fault and observation data *** 
c 
      open(9,file='fault_dat',status='unknown') 
        write(9,9500)XHYPO,YHYPO,ZHYPO 
        write(9,9500)xflt,yflt,zflt 
        write(9,9500)STR,DIP,RAK(1,1) 
        write(9,9500)slength,dwidth,VR 
        write(9,9510)NSTR,NDIP,ngauss 
        if(ngauss.gt.6)then 
          write(*,*)'Num. of Gauss points	> 6 !!!! ' 
          stop 
        end if 
c        do 700 iflt=1,nf 
c        do 700 id=1,ngauss 
c        do 700 ig=1,ngauss 
c        write(9,9500)xf(iflt,id,ig),yf(iflt,id,ig),dp(iflt,id) 
c  700   continue 
 9500   format(3f12.4) 
 9510   format(3i12) 
      close(9)  
c 
      open(9,file='obs_dat',status='unknown') 
        do i=1,nob 
        write(9,9500)xo(i),yo(i),zo(i) 
        end do 
      close(9)  
C 
C *** OUTPUT OF INTEGRAND OF U,V,AND W *** 
C 
      IOT=0
      IF(NOB.NE.1)RETURN 
      IF(NF.NE.1)RETURN 
c      IF((NOM-IOM).NE.0)RETURN 
C 
c      WRITE(*,7000) 
c      READ(*,*)IOT 
c 7000 FORMAT(/' Output Integrands?: Enter No=0 or Yes=1: ') 
C 
      df0=dom/6.283185307d0 
      if(iot.eq.1)then 
        f1=0.d0 
        f2=df0*nom 
        write(*,*) 
        write(*,*)'Frequency Range (Hz) =',f1,f2 
        write(10,*)'Frequency Range (Hz) =',f1,f2 
        write(*,*)'Enter Output Frequency (Hz)' 
        read(*,*)ofreq 
        df=9999.d0 
        do i=1,nom+1 
          freq=df0*(i-1) 
          dfreq=dabs(freq-ofreq) 
          if(dfreq.lt.df)then 
            ioutom=i 
            df=dfreq 
          end if 
        end do 
        write(*,*)'Actual Output Frequency (Hz)=',df0*(ioutom-1) 
        write(10,*)'Actual Output Frequency (Hz)=',df0*(ioutom-1) 
        write(*,*) 
        write(*,*)'  You can plot the integrands using "integ.m",' 
        write(*,*)'  "integr.m", and "integz.m" for "MATLAB"' 
c 
        open(9,file='in_dat',status='unknown') 
          write(9,9000)dom*iom 
          write(9,9100)nl 
          do 500 i=1,nl 
            write(9,9000)vp(i) 
            write(9,9000)vs(i) 
 500      continue 
        close(9) 
 9000   format(e15.7) 
 9100   format(i5) 
c 
      end if 
 
      RETURN 
      END 
C 
C 
C *** PHASE VELOCITY OF THE RAYLEIGH WAVE IN THE HOMOGENEOUS HALF-SPACE *** 
C 
      FUNCTION FRHF(VP,VS) 
      IMPLICIT REAL*8(A-H,O-Z) 
C 
      DZ=0.0001D0 
C 
      SP=VS/VP 
      IF(SP.GE.0.0D0) Z= 0.91263D0 
      IF(SP.GE.0.2D0) Z= 0.90767D0 
      IF(SP.GE.0.4D0) Z= 0.88899D0 
      IF(SP.GE.0.6D0) Z= 0.83575D0 
      IF(SP.GE.0.7D0) Z= 0.77062D0 
      IF(SP.GE.0.8D0) Z= 0.63338D0 
C 
      F0=FRHF1(SP,Z) 
  100 Z=Z-DZ 
      F1=FRHF1(SP,Z) 
      AF=F0/F1 
      F00=F0 
      F0 =F1 
      IF(AF.GE.0.D0)GOTO 100 
      FZ=Z+DZ*F0/(F0-F00) 
C 
      FRHF=VS*DSQRT(FZ) 
C 
      RETURN 
      END 
C 
C 
      FUNCTION FRHF1(SP,Z) 
      IMPLICIT REAL*8(A-H,O-Z) 
C 
      Z2=Z*Z 
      Z3=Z2*Z 
C 
      F1=16.D0*(Z-1.D0)*SP*SP 
      FRHF1=F1-Z3+8.D0*Z2-24.D0*Z+16.D0 
C 
      RETURN 
      END 
C 
C 
C *** DATA OUTPUT *** 
C 
      SUBROUTINE OTDAT(MOM,MOB,GX,GY,GZ) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 GX(MOM,MOB),GY(MOM,MOB),GZ(MOM,MOB)
      COMMON /FREQ/DOM,IOM,NOM,OMI /OBS/XO(51),YO(51),ZO(51),NOB 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     *    /IFLT/NF,NTW,IS,ngauss,ndip,nstr,iramp /SIGN/ISIGN
C 
C *** CHECK *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)'FROM OTDAT:NL>NC',NL,NC 
         STOP 
      END IF 
C 
      NC=51 
      IF(NOB.GT.NC)THEN 
         WRITE(10,*)'FROM OTDAT:NOB>NC',NOB,NC 
         STOP 
      END IF 
C 
      NC=203 
      IF(NF.GT.NC)THEN 
         WRITE(10,*)'FROM OTDAT:NF>NC',NF,NC 
         STOP 
      END IF 
C 
C *** OUTPUT OF DATA (GX, GY AND GZ)*** 
C 
      IF(ISIGN.EQ.1)THEN 
        DO 100 IOB=1,NOB 
        DO 110 K=IOM,NOM+1 
          GX(K,IOB)=DCMPLX(DREAL(GX(K,IOB)),-DIMAG(GX(K,IOB))) 
          GY(K,IOB)=DCMPLX(DREAL(GY(K,IOB)),-DIMAG(GY(K,IOB))) 
          GZ(K,IOB)=DCMPLX(DREAL(GZ(K,IOB)),-DIMAG(GZ(K,IOB))) 
  110   CONTINUE 
  100   CONTINUE 
      END IF 
C       
      OPEN(UNIT=8,FILE='grfault.dxyz',STATUS='UNKNOWN') 
        WRITE(8,2500)DOM,IOM,NOM,OMI 
        WRITE(8,2510)NOB 
        DO 500 IOB=1,NOB 
          DO 510 K=IOM,NOM+1 
            WRITE(8,2520)GX(K,IOB),GY(K,IOB),GZ(K,IOB) 
  510     CONTINUE 
  500   CONTINUE 
      CLOSE(8) 
C 
 2500 FORMAT(1X,F10.6,2I10,F10.7) 
 2510 FORMAT(1X,I10,///) 
 2520 FORMAT(1X,6E12.5) 
C
      RETURN 
      END 
c
C 
C *** COMPUTATION OF Static GREEN FUNCTIONS USING THE R/T METHOD *** 
C 
      SUBROUTINE HKQVWs(MOM,MOB,SMOs,GXS,GYS,GZS) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 GXs(MOM,MOB),GYs(MOM,MOB),GZs(MOM,MOB),SMOs(MOM,15)
      COMPLEX*16 SM,RAM,OM,OM1,im,VSc,VS2,VPc,VP2,SMO
     *      ,QXS(0:2),QZS(0:2),VXS(0:2),WXS(0:2),WZS(0:2)
     *      ,QXG(0:2),QZG(0:2),VXG(0:2),WXG(0:2),WZG(0:2) 
     *      ,EDT0,EDT,GX,GY,GZ,QA,QB,VA,VB,WA,WB,GX0,GY0,GZ0 
     *      ,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 ENs(3,3,15),gw(8,8),gaux(8,8) 
c      dimension dc(203),sc(203),RRm(203)
      dimension RRm(203)
      COMMON /FREQ/DOM,IOM,NOM,OMI /OBS/XO(51),YO(51),ZO(51),NOB
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     *    /FLT/STR,DIP,RAK(203,15),FL,FW,VR,FD(203,15),RT(2,15),TWI 
     *        ,xflt,yflt,zflt,delay 
     *    /IFLT/NF,NTW,IS,ngauss,ndip,nstr,iramp  
     *    /Hypo/xhypo,yhypo,zhypo  
     *    /OTST/IOT,IST  /FCQVW/SM,RAM,RR  /SOLY/SDEP,ODEP,LS,LO 
     *    /WVNUMs/WNRs(3),NWN1o,NWN2o,NWN1,NWN2,NWT1,NWT2
c 
      data gaux(1,1)/0.0d0/ 
      data gaux(1,2),gaux(2,2) 
     * /-0.577350269189626d0, 0.577350269189626d0/ 
      data gaux(1,3),gaux(2,3),gaux(3,3) 
     * /-0.774596669241483d0,0.d0, 0.774596669241483d0/ 
      data gaux(1,4),gaux(2,4),gaux(3,4),gaux(4,4) 
     * /-0.861136311594053d0,-0.339981043584856d0 
     * , 0.339981043584856d0, 0.861136311594053d0/ 
      data gaux(1,5),gaux(2,5),gaux(3,5),gaux(4,5),gaux(5,5) 
     * /-0.906179845938664d0,-0.538469310105683d0,0.0d0 
     * , 0.538469310105683d0, 0.906179845938664d0/ 
      data gaux(1,6),gaux(2,6),gaux(3,6),gaux(4,6),gaux(5,6),gaux(6,6) 
     * /-0.932469514203152d0,-0.661209386466265d0,-0.238619186083197d0 
     * , 0.238619186083197d0, 0.661209386466265d0, 0.932469514203152d0/  
c 
      data gw(1,1) /2.d0/ 
      data gw(1,2),gw(2,2) /1.d0,1.d0/ 
      data gw(1,3),gw(2,3),gw(3,3) 
     * / 0.555555555555556d0, 0.888888888888889d0, 0.555555555555556d0/ 
      data gw(1,4),gw(2,4),gw(3,4),gw(4,4) 
     * / 0.347854845137454d0, 0.652145154862546d0 
     * , 0.652145154862546d0, 0.347854845137454d0/ 
      data gw(1,5),gw(2,5),gw(3,5),gw(4,5),gw(5,5) 
     * / 0.236926885056189d0, 0.478628670499366d0, 0.568888888888889d0 
     * , 0.478628670499366d0, 0.236926885056189d0/ 
      data gw(1,6),gw(2,6),gw(3,6),gw(4,6),gw(5,6),gw(6,6) 
     * / 0.171324492379170d0, 0.360761573048139d0, 0.467913934572691d0 
     * , 0.467913934572691d0, 0.360761573048139d0, 0.171324492379170d0/ 
C 
C *** CHECK OF DIMENSION *** 
C 
      WRITE(*,*)
      NC=20
      IF(NL.GE.NC)THEN 
        WRITE(10,*)' FROM HKQVWs:NL>NC !!!!!!!!!!'
        WRITE(10,*)' NL,NC=',NL,NC 
        STOP 
      END IF 
C 
      NC=51 
      IF(NOB.GE.NC)THEN 
        WRITE(10,*)' FROM HKQVWs:NOB>NC !!!!!!!!!!'
        WRITE(10,*)' NOB,NC=',NOB,NC 
        STOP 
      END IF 
C 
      NC=MOB 
      IF(NOB.GE.NC)THEN 
        WRITE(10,*)' FROM HKQVWs:NOB>MOB !!!!!!!!!!'
        WRITE(10,*)' NOB,NC=',NOB,MOB 
        STOP 
      END IF 
C 
      NC=203 
      IF(NF.GE.NC)THEN 
        WRITE(10,*)' FROM HKQVWs:NF>NC !!!!!!!!!!'
        WRITE(10,*)' NF,NC=',NF,NC 
        STOP 
      END IF 
C 
c     * Omega Data * 
c 
      OM=dcmplx(0.d0,OMI) 
C 
C   * output of integrands for check * 
C 
      write(*,*)'From HKQVWs:'
      write(*,*)'Output Static Integrands?'
      write(*,*)'  Enter 0 for No  (Regular)' 
      write(*,*)'  Enter 1 for YES (Checking Purpse Only' 
      read(*,*)IOT 
c 
      IF(IOT.eq.1)THEN 
        write(*,*)'  The first Observation Point is used as the Source l
     *ocation.' 
        write(*,2000)xo(1),yo(1),zo(1) 
2000    format('   Source Location (x,y,z: m)=',3f12.4) 
        write(*,*)'  Enter the location of Observation Point (x,y,z: m)' 
        read(*,*)xot,yot,zot 
        OPEN (20,FILE='sint1_d',STATUS='unknown') 
        OPEN (21,FILE='sint2_d',STATUS='unknown') 
      END IF 
C 
c 
c *** The fault integration for the static solutions *** 
c 
c      write(1,*)'STR,DIP',STR,DIP 
c      write(1,*)'FL,FW',FL,FW 
c      write(1,*)'xflt,yflt,zflt',xflt,yflt,zflt   
 
      im=DCMPLX(0.d0,1.d0) 
      cdp=dcos(dip) 
      sdp=dsin(dip) 
      cst=dcos(str) 
      sst=dsin(str) 
c 
      DO 100 IOB=1,NOB 
c 
        if(iot.eq.1)then 
c            dc(1)=1.d0
c            sc(1)=1.d0
            RRm(1)=9999999.d0 
            goto 25 
        end if 
        write(10,*)
        write(10,*)'from HKQVWs: iob=',iob
c 
c     * Finding the closest distance between OB and sub-fault planes * 
c 
        Rmin1=9999999999.d0
        xc1=0.d0
        yc1=0.d0
        zc1=0.d0
        DO 200 idip=1,ndip  
c
          d10=FW*(idip-1)
c          d20=FW*idip
c          zflt1=zflt-d10*sdp
c          zflt2=zflt-d20*sdp
c 
          DO 220 istr=1,nstr 
c 
c          write(1,*) 
c          write(1,*)'iob,idip,istr  =',iob,idip,istr 
c             
            s10=FL*(istr-1) 
c            s20=FL*istr
c            xflt1=xflt+s10*cst+d10*cdp*sst
c            xflt2=xflt+s20*cst+d20*cdp*sst
c            yflt1=yflt+s10*sst-d10*cdp*cst
c            yflt2=yflt+s20*sst-d20*cdp*cst
c 
c            write(1,*)'Flt Corner 1: x,y,z',xflt1,yflt1,zflt1 
c            write(1,*)'Flt Corner 2: x,y,z',xflt2,yflt2,zflt2 
c 
            dRR=0.0000001d0 
            Rmin=99999999999.d0 
            Rold=Rmin 
            iloop=1 
            d0=d10 
            s0=s10 
            Dwid=FW 
            Slen=FL 
c 
 10         d1=d0+Dwid/4.d0 
            d2=d0+Dwid*3.d0/4.d0 
            Z1=zflt-d1*sdp 
            Z2=zflt-d2*sdp 
            RZ1=Z1-ZO(IOB) 
            RZ2=Z2-ZO(IOB) 
c       write(1,*) 
c       write(1,*)'1:iloop',iloop 
c       write(1,*)'1:d0,s0',d0,s0 
c       write(1,*)'dwid,slen',dwid,slen 
c       write(1,*)'d1,s1',d1,s1 
c       write(1,*)'d2,s2',d2,s2 
c       write(1,*)'z1,z2',z1,z2 
c 
            s1=s0+Slen/4.d0 
            s2=s0+Slen*3.d0/4.d0 
            X1=xflt+s1*cst+d1*cdp*sst 
            X2=xflt+s2*cst+d2*cdp*sst 
            Y1=yflt+s1*sst-d1*cdp*cst 
            Y2=yflt+s2*sst-d2*cdp*cst 
c 
            X11=xflt+s1*cst+d1*cdp*sst 
            Y11=yflt+s1*sst-d1*cdp*cst 
            X12=xflt+s2*cst+d1*cdp*sst 
            Y12=yflt+s2*sst-d1*cdp*cst 
            X21=xflt+s1*cst+d2*cdp*sst 
            Y21=yflt+s1*sst-d2*cdp*cst 
            X22=xflt+s2*cst+d2*cdp*sst 
            Y22=yflt+s2*sst-d2*cdp*cst 
c 
c        write(1,*)'x11,y11',x11,y11 
c        write(1,*)'x12,y12',x12,y12 
c        write(1,*)'x21,y21',x21,y21 
c        write(1,*)'x22,y22',x22,y22 
c 
            RX11=X11-XO(IOB) 
            RX12=X12-XO(IOB) 
            RX21=X21-XO(IOB) 
            RX22=X22-XO(IOB) 
            RY11=Y11-YO(IOB) 
            RY12=Y12-YO(IOB) 
            RY21=Y21-YO(IOB) 
            RY22=Y22-YO(IOB) 
c      write(1,*)'xo,yo,zo',xo(IOB),yo(IOB),zo(IOB) 
c      write(1,*)'rx11,ry11',rx11,ry11 
c      write(1,*)'rx12,ry12',rx12,ry12 
c      write(1,*)'rx21,ry21',rx21,ry21 
c      write(1,*)'rx22,ry22',rx22,ry22 
c      write(1,*)'rz1,rz2',rz1,rz2 
            R11=DSQRT(RX11*RX11+RY11*RY11+RZ1*RZ1) 
            R12=DSQRT(RX12*RX12+RY12*RY12+RZ1*RZ1) 
            R21=DSQRT(RX21*RX21+RY21*RY21+RZ2*RZ2) 
            R22=DSQRT(RX22*RX22+RY22*RY22+RZ2*RZ2) 
c      write(1,*)'R11,R12',R11,R12 
c       write(1,*)'R21,R22',R21,R22 
c         
            imin=0 
            if(R11.lt.Rmin)then 
              imin=11 
              Rmin=R11*(1.d0-dRR/10000.d0) 
            end if 
            if(R12.lt.Rmin)then 
              imin=12 
              Rmin=R12*(1.d0-dRR/10000.d0) 
            end if 
            if(R21.lt.Rmin)then 
              imin=21 
              Rmin=R21*(1.d0-dRR/10000.d0) 
            end if 
            if(R22.lt.Rmin)then 
              imin=22 
              Rmin=R22*(1.d0-dRR/10000.d0) 
            end if 
c         
c      write(1,*)'imin',imin 
c      if(imin.eq.11)then 
c        write(2,999)iob,idip,istr,imin,x11,y11,z1,r11 
c      end if 
c      if(imin.eq.12)then 
c        write(2,999)iob,idip,istr,imin,x12,y12,z1,r12 
c      end if 
c      if(imin.eq.21)then 
c        write(2,999)iob,idip,istr,imin,x21,y21,z2,r21 
c      end if 
c      if(imin.eq.22)then 
c        write(2,999)iob,idip,istr,imin,x22,y22,z2,r22 
c      end if 
c999      format(4i5,4f12.4) 
c 
            if(imin.ne.0)then 
c 
              if(imin.eq.12)then 
                s0=s0+Slen/2.d0 
              else 
                if(imin.eq.21)then 
                  d0=d0+Dwid/2.d0 
                else  
                  if(imin.eq.22)then 
                    s0=s0+Slen/2.d0 
                    d0=d0+Dwid/2.d0 
                  end if 
                end if 
              end if 
c 
            else 
c 
              Rmin=999999999999.d0 
              jmin=0 
              if(R11.lt.Rmin)then 
                jmin=11 
                Rmin=R11*(1.d0-dRR/10000.d0) 
              end if  
              if(R12.lt.Rmin)then 
                jmin=12 
                Rmin=R12*(1.d0-dRR/10000.d0) 
              end if         
              if(R21.lt.Rmin)then 
                jmin=21 
                Rmin=R21*(1.d0-dRR/10000.d0) 
              end if  
              if(R22.lt.Rmin)then 
                jmin=22 
                Rmin=R22*(1.d0-dRR/10000.d0) 
              end if  
c 
c       write(1,*)'jmin',jmin 
c 
              if(jmin.eq.12)then 
                s0=s0+Slen/2.d0 
              else 
                if(jmin.eq.21)then 
                  d0=d0+Dwid/2.d0 
                else  
                  if(jmin.eq.22)then 
                    s0=s0+Slen/2.d0 
                    d0=d0+Dwid/2.d0 
                  end if 
                end if 
              end if 
c 
            end if  
c 
c 20         write(1,*)'2:iloop,imin',iloop,imin 
c        write(1,*)'Rold,Rmin',Rold,Rmin 
c        write(1,*)'2:d0,s0',d0,s0 
 
c      if(dabs(Rmin-Rold).gt.dRR)then 
        if(dabs(Rmin-Rold).gt.dRR)then
c 
              iloop=iloop+1 
              Dwid=Dwid/2.d0 
              Slen=Slen/2.d0 
              if(iloop.gt.100)then 
                write(*,*)'iloop > 100 !!!' 
                write(*,*)'The observation point might be too ' 
                write(*,*)'close to the fault plane!: IOB=',IOB 
                stop 
              end if 
              Rold=Rmin     
              goto 10 
c 
            else 
c 
              Rmin0=R11 
              if(R12.lt.Rmin0)then 
                Rmin0=R12 
              else 
                if(R21.lt.Rmin0)then 
                  Rmin0=R21 
                else 
                  if(R22.lt.Rmin0)then 
                    Rmin0=R22 
                  end if 
                end if 
              end if 
c 
              Rmax0=R11 
              if(R12.gt.Rmax0)then 
                Rmax0=R12 
              else 
                if(R21.gt.Rmax0)then 
                  Rmax0=R21 
                else 
                  if(R22.gt.Rmax0)then 
                    Rmax0=R22 
                  end if 
                end if 
              end if 
c 
c      write(1,*) 
c      write(1,*)'Rmax0,Rmin0',Rmax0,Rmin0 
c 
              if((Rmax0-Rmin0).gt.dRR)then 
                iloop=iloop+1 
                Dwid=Dwid/2.d0 
                Slen=Slen/2.d0 
                if(iloop.gt.100)then 
                  write(*,*)'iloop > 100 !!!' 
                  write(*,*)'The observation point might be too ' 
                  write(*,*)'close to the fault plane!: IOB=',IOB 
                  stop 
                end if 
                Rold=Rmin     
                goto 10 
              end if 
c 
            end if 
c 
            xc=(x1+x2)/2.d0 
            yc=(y1+y2)/2.d0 
            zc=(z1+z2)/2.d0 
c 
            IS=nstr*(idip-1)+istr 
c            dc(IS)=(d1+d2)/2.d0
c            sc(IS)=(s1+s2)/2.d0
            RRm(IS)=Rmin         
 
c        write(1,*)'FW,FL',FW,FL 
c        write(1,*) 
c        write(1,*)'dc,sc',dc(IS),sc(IS) 
c        write(1,9990)xc,yc,zc 
c        write(*,*)'dc,sc',dc(IS),sc(IS) 
c        write(10,9990)xc,yc,zc
c 9990   format(' xc,yc,zc=',3f12.3)
c        write(1,*)'Rmin,iloop',Rmin,iloop 
c        write(10,*)'Rmin,iloop ',Rmin,iloop
        if(Rmin.lt.Rmin1)then
          Rmin1=Rmin
          xc1=xc
          yc1=yc
          zc1=zc
        end if
c 
 220    CONTINUE 
 200    CONTINUE 
 
        write(*,*) 
        write(*,*)'Observation Point Number = ',IOB
        write(*,*)'  Closest Distance from OB to Fault Plane & Location'
        write(*,*)'  Rmin (m) = ',Rmin1
        write(*,*)'  xc,yc,zc = ',xc1,yc1,zc1 
        write(*,*)       
c 
c *** The fault integration for the static solutions *** 
C  
  25    ZS=ZO(IOB) 
        if(iob.ge.2)then 
          if(zs.eq.zo(iob-1))goto 30 
        end if 
c 
        DRU=0.d0
        DRL=THK(1) 
        DO 250 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) 
 250    CONTINUE 
C 
        DEP1=0.d0
        DO 270 L=1,LS-1 
            DEP1=DEP1+THK(L) 
 270    CONTINUE 
        SDEP=ZS-DEP1 
c 
c     * Starting Fault Integration * 
c 
 30     GX0=(0.D0,0.D0) 
        GY0=(0.D0,0.D0) 
        GZ0=(0.D0,0.D0) 
c 
        ngdipT=0 
        ngstrT=0 
        ngT=0 
        NWT1=0 
        NWT2=0 
c
        DO 300 idip=1,ndip  
c
            write(*,*)' idip =',idip
            da=FW*(idip-1) 
            db=FW*idip 
            za=zflt-da*sdp*1.0000001d0 
            zb=zflt-db*sdp*0.9999999d0 
            if(zb.lt.0.d0)then 
              write(*,*)'Fault Depth is less than 0!: Dip Number=',idip 
              stop 
            end if 
            DRU=0.d0
            DRL=THK(1) 
            do L=1,NL 
              IF((za.GE.DRU).AND.(za.LT.DRL))L1=L 
              IF((za.GE.DRU).AND.(L.EQ.NL))  L1=L 
              DRU=DRL 
              DRL=DRL+THK(L+1) 
            end do 
            DRU=0.d0
            DRL=THK(1) 
            do L=1,NL 
              IF((zb.GE.DRU).AND.(zb.LT.DRL))L2=L 
              IF((zb.GE.DRU).AND.(L.EQ.NL))  L2=L 
              DRU=DRL 
              DRL=DRL+THK(L+1) 
            end do 
            if(L1.ne.L2)then 
              write(*,*)' The L1 Layer is different from the L2 Layer!' 
              write(*,*)' Layers 1 and 2 =',L1,L2 
c             stop 
            end if 
c 
          DO 320 istr=1,nstr 
c
c   * Source Time Function of Each Sub-Fault (Note; The values are devided by SM) *
c
           IS=nstr*(idip-1)+istr 
           call MOs(ENs,SMOs,MOM)
c 
c          write(*,*) 
c          write(*,*)'iob,idip,istr',iob,idip,istr 
c            IS=nstr*(idip-1)+istr 
            rWS=FW/RRm(IS) 
            rLS=FL/RRm(IS) 
            NWS=int(rWS)
            NLS=int(rLS)
            if(rWS.le.0.8d0)NWS=2
            if(rLS.le.0.8d0)NLS=2
            if(rWS.le.0.6d0)NWS=1
            if(rLS.le.0.6d0)NLS=1
            if(NWS.lt.1)NWS=1             
            if(NLS.lt.1)NLS=1          
c         write(*,*)'rWS,rLS',rWS,rLS 
c         write(*,*)'NWS,NLS',NWS,NLS 
            if(NWS.gt.500)then 
               write(*,*)'Warning! NWS > 500',NWS 
               write(*,*)'The OB might be too close to the fault !' 
               write(*,*)'iob,idip,istr',iob,idip,istr 
            end if 
            if(NLS.gt.500)then 
               write(*,*)'Warning! NLS > 500',NLS 
               write(*,*)'The OB might be too close to the fault !' 
               write(*,*)'iob,idip,istr',iob,idip,istr 
            end if 
c 
            dWS=FW/dfloat(NWS) 
            dLS=FL/dfloat(NLS) 
            if(dWS.gt.FW)dWS=FW 
            if(dLS.gt.FL)dLS=FL 
c         write(*,*)'dWS,dLS',dWS,dLS 
c
c   * Fault Integration on Sub Sub-Faults *
c  
           ngdipS=0 
           ngstrS=0 
           ngS=0 
           do 400 iWS=1,NWS 
c 
            da=FW*(idip-1)+dWS*(iWS-1) 
            db=FW*(idip-1)+dWS*iWS 
            dcn=(da+db)/2.d0 
            za=zflt-da*sdp*1.0000001d0 
            zb=zflt-db*sdp*0.9999999d0 
            zcn=(za+zb)/2.d0 
c   
            do 420 iLS=1,NLS 
c 
              sa=FL*(istr-1)+dLS*(iLS-1) 
              sb=FL*(istr-1)+dLS*iLS 
              scn=(sa+sb)/2.d0 
              xcn=xflt+scn*cst+dcn*cdp*sst 
              ycn=yflt+scn*sst-dcn*cdp*cst 
              xn=xcn-xo(iob) 
              yn=ycn-yo(iob) 
              zn=zcn-zo(iob) 
              Rcn=dsqrt(xn*xn+yn*yn+zn*zn) 
c       write(*,*)'iWS,iLS',iWS,iLS 
c       write(*,*)'da,db',da,db 
c       write(*,*)'sa,sb',sa,sb 
c       write(*,*)'Rcn',Rcn 
              ratioW=Rcn/dWS  
              ratioL=Rcn/dLS  
c       write(*,*)'ratioW,ratioL',ratioW,ratioL 
 
            ngausW=1 
            if(ratioW.lt.100.0d0)then 
              ngausW=2 
              if(ratioW.lt.10.0d0)then 
                ngausW=3 
                if(ratioW.lt.4.0d0)then 
                  ngausW=4 
                  if(ratioW.lt.2.0d0)then 
                    ngausW=5 
                    if(ratioW.lt.1.0d0)then 
                      ngausW=6 
                      if(ratioW.lt.0.5d0)then 
                  write(*,*)'ngausW > 6 !!!!' 
                  write(*,*)'ngausW > 6 -> ngausW = 6' 
                        ngausW=6 
                      end if 
                    end if 
                  end if 
                end if 
              end if 
            end if 
c 
            ngausL=1 
            if(ratioL.lt.100.0d0)then 
              ngausL=2 
              if(ratioL.lt.10.0d0)then 
                ngausL=3 
                if(ratioL.lt.4.0d0)then 
                  ngausL=4 
                  if(ratioL.lt.2.0d0)then 
                    ngausL=5 
                    if(ratioL.lt.1.0d0)then 
                      ngausL=6 
                      if(ratioL.lt.0.5d0)then 
                  write(*,*)'ngausL > 6 !!!!' 
                  write(*,*)'ngausL > 6 -> ngausL = 6' 
                        ngausL=6 
                      end if 
                    end if 
                  end if 
                end if 
              end if 
            end if 
c 
        ngdipS=ngdipS+ngausL 
        ngstrS=ngstrS+ngausW 
        ngS=ngS+ngausL*ngausW 
c 
c            write(*,1200)idip,za,zb          
c            write(*,1210)ratioW,ngausW 
c            write(*,1220)ratioL,ngausL 
c            write(10,1200)idip,za,zb          
c            write(10,1210)ratioW,ngausW 
c            write(10,1220)ratioL,ngausL 
c 1200     format(' Elem Num.for W, and the edge depths =',i3,2f11.2) 
c 1210     format(' Dist. Ratio & Gauss Pts per Sub-W =',e12.4,' ->',i3) 
c 1220     format(' Dist. Ratio & Gauss Pts per Sub-L =',e12.4,' ->',i3) 
c 
c           * Gaussian Quadrature (id*ig points) * 
c 
            do 500 id=1,ngausW 
c 
              zd=((1.d0-gaux(id,ngausW))*za 
     *           +(1.d0+gaux(id,ngausW))*zb)/2.d0 
              if(iot.eq.1)zd=zot 
c      write(*,*)'zd ',zd 
c   
              DRU=0.d0
              DRL=THK(1) 
              do L=1,NL 
                IF((zd.GE.DRU).AND.(zd.LT.DRL))L1=L 
                IF((zd.GE.DRU).AND.(L.EQ.NL))  L1=L 
                DRU=DRL 
                DRL=DRL+THK(L+1) 
              end do 
              zz=zd-zhypo 
c 
              LO=L1 
              QPe=FuncQP(dcmplx(0.d0,OMI),LO)
              QSe=FuncQS(dcmplx(0.d0,OMI),LO)
              VPc=VP(LO)*DCMPLX(1.D0,-0.5D0/QPe) 
              VSc=VS(LO)*DCMPLX(1.D0,-0.5D0/QSe) 
              VP2=VPc*VPc 
              VS2=VSc*VSc 
c
              SM = DNS(LO)*VS2 
              RAM= DNS(LO)*VP2-2.D0*SM 
C 
              ZZO=zd 
              ODEP=ZZO 
              DO L=2,LO 
                ODEP=ODEP-THK(L-1) 
              end do 
c      write(*,*)'SM,RAM ',SM,RAM 
c      write(*,*)'SDEP,ODEP ',SDEP,ODEP 
C 
              dd=((1.d0-gaux(id,ngausW))*da 
     *           +(1.d0+gaux(id,ngausW))*db)/2.d0 
c      
              do 550 ig=1,ngausL 
c 
                sg=((1.d0-gaux(ig,ngausL))*sa 
     *             +(1.d0+gaux(ig,ngausL))*sb)/2.d0 
                XF=xflt+sg*cst+dd*cdp*sst 
                YF=yflt+sg*sst-dd*cdp*cst 
                if(iot.eq.1)then 
                  XF=xot 
                  YF=yot 
                end if 
c 
                xx=XF-xhypo 
                yy=YF-yhypo 
                xy=dsqrt(xx*xx+yy*yy+zz*zz) 
                TD=delay+xy/vr             
                RX=XF-XO(IOB) 
                RY=YF-YO(IOB) 
                RR=DSQRT(RX*RX+RY*RY) 
c      write(*,*)'xf,yf,zd ',xf,yf,zd 
c      write(*,*)'rx,ry,rr ',rx,ry,rr 
c       write(*,*)'idip,istr,id,ig',idip,istr,id,ig 
c       write(*,*)'xhypo,yhypo,zhypo',xhypo,yhypo,zhypo 
c 
C 
                DO J=0,2 
                  QXG(J)=(0.D0,0.D0) 
                  VXG(J)=(0.D0,0.D0) 
                  WXG(J)=(0.D0,0.D0) 
                  QZG(J)=(0.D0,0.D0) 
                  WZG(J)=(0.D0,0.D0) 
                  QXS(J)=(0.D0,0.D0) 
                  VXS(J)=(0.D0,0.D0) 
                  WXS(J)=(0.D0,0.D0) 
                  QZS(J)=(0.D0,0.D0) 
                  WZS(J)=(0.D0,0.D0) 
                end do 
C 
c         * the wavenumber integration using Simpson's and Filon's fomulas * 
c 
                NWN1=NWN1o 
                NWN2=NWN2o 
                CALL QVWRZS1(OM,QXG,QZG,VXG,WXG,WZG) 
                CALL QVWRZS2(OM,QXS,QZS,VXS,WXS,WZS) 
c 
c      write(*,*)'VX1',VXG(1) 
c      write(*,*)'VX2',VXG(2) 
c      write(*,*)'VX1',VXS(1),VXG(1) 
c      write(*,*)'VX2',VXS(2),VXG(2) 
c      write(*,*)'QX0',QXS(0),QXG(0) 
c      write(*,*)'QX1',QXS(1),QXG(1) 
c      write(*,*)'QX2',QXS(2),QXG(2) 
c      write(*,*)'VX1',VXS(1),VXG(1) 
c      write(*,*)'VX2',VXS(2),VXG(1) 
c      stop 
c       write(2,*)'rx,ry,rr',rx,ry,rr 
c      write(2,9999)QXS(2),QXG(2),QXS(2)+QXG(2) 
c 9999      format(10e12.4) 
c 
c         * see Hisada(1994) eq.(26) * 
                CR=RX/RR 
                SR=RY/RR 
                C2=CR*CR 
                S2=SR*SR 
                CS=CR*SR 
                CX=S2/RR 
                SY=C2/RR 
                CY=-CS/RR 
                SX=CY 
C        
c         * Urx, Ury, Urz: see Hisada(1994) eq.(11) * 
                QA=QXG(0)+QXS(0) 
                  QX(0)=QA*CR 
                  QY(0)=QA*SR 
                  QZ(0)=-(QZG(0)+QZS(0)) 
C 
c         * Utx, Uty     : see Hisada(1994) eq.(11) * 
                VA=VXG(0)+VXS(0) 
                  VX(0)=-VA*SR 
                  VY(0)= VA*CR 
C              
c         * Uzx, Uzy, Uzz: see Hisada(1994) eq.(11) * 
                WA=WXG(0)+WXS(0) 
                  WX(0)=-WA*CR 
                  WY(0)=-WA*SR 
                  WZ(0)=-(WZG(0)+WZS(0)) 
c              
c         * Urx,x, Ury,x, Urx,y, Ury,y, Urz,x Urz,y: see Hisada(1994) eq.(27) * 
                QB=QXG(1)+QXS(1) 
                  QX(1)=QB*C2+QA*CX 
                  QY(1)=QB*CS+QA*SX 
                  QX(2)=QB*CS+QA*CY 
                  QY(2)=QB*S2+QA*SY 
c       write(*,*)'QA',QA 
c       write(*,*)'QB',QB 
c       write(*,*)'C2',C2 
c       write(*,*)'CX',CX 
                QB=QZG(1)+QZS(1) 
                  QZ(1)=-QB*CR 
                  QZ(2)=-QB*SR 
c 
 
c         * Utx,x, Uty,x, Utx,y, Uty,y: see Hisada(1994) eq.(27) * 
                VB=VXG(1)+VXS(1) 
                  VX(1)=-(VB*CS+VA*SX) 
                  VY(1)=  VB*C2+VA*CX 
                  VX(2)=-(VB*S2+VA*SY) 
                  VY(2)=  VB*CS+VA*CY 
c     
c         * Uzx,x, Uzy,x, Uzx,y, Uzy,y, Uzz,x Uzz,y: see Hisada(1994) eq.(27)  
                WB=WXG(1)+WXS(1) 
                  WX(1)=-(WB*C2+WA*CX) 
                  WY(1)=-(WB*CS+WA*SX) 
                  WX(2)=-(WB*CS+WA*CY) 
                  WY(2)=-(WB*S2+WA*SY) 
                  WB=WZG(1)+WZS(1) 
                  WZ(1)=-WB*CR 
                  WZ(2)=-WB*SR 
c 
c         * Urx,z, Ury,z, Urz,z: see Hisada(1994) eq.(29) * 
                QB=QXG(2)+QXS(2) 
                  QX(3)= QB*CR 
                  QY(3)= QB*SR 
                  QZ(3)=-(QZG(2)+QZS(2)) 
c              
c         * Utx,z, Uty,z: see Hisada(1994) eq.(29) * 
                VB=VXG(2)+VXS(2) 
                  VX(3)=-VB*SR 
                  VY(3)= VB*CR 
c            
c         * Uzx,z, Uzy,z, Uzz,z: see Hisada(1994) eq.(29) * 
                WB=WXG(2)+WXS(2) 
                  WX(3)=-WB*CR 
                  WY(3)=-WB*SR 
                  WZ(3)=-(WZG(2)+WZS(2)) 
C              
c         * Uxx,x, Uxx,y, Uxy,x, Uxy,y, Uxz,x, Uxz,y: see Hisada(1994) eq.(24) * 
                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        
c         * Uyx,x, Uyx,y, Uyy,x, Uyy,y, Uyz,x, Uyz,y: see Hisada(1994) eq.(24) * 
                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 
c         * Uzx,x, Uzx,y, Uzy,x, Uzy,y, Uzz,x, Uzz,y: see Hisada(1994) eq.(27) * 
                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 
c         * Uxx,z, Uxy,z, Uxz,z, Uyx,z, Uyy,z, Uyz,z: see Hisada(1994) eq.(25) * 
                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 
C 
c         * Uzx,z, Uzy,z, Uzz,z: see Hisada(1994) eq.(29) * 
                UX(3,3)=WX(3) 
                UY(3,3)=WY(3) 
                UZ(3,3)=WZ(3) 
c 
c               * Time Windows * 
c 
            IS=nstr*(idip-1)+istr 
            DO 600 IO=IOM,NOM+1 
              OMR=DOM*DFLOAT(IO-1) 
              OM1=dcmplx(OMR,OMI) 
              EDT=CDEXP(im*OM1*TD) 
                DO 620 itw=1,ntw 
c                  CALL MO(itw,OM1,en,SMO) 
c                  SMO=SMO/dfloat(nWS*nLS) 
                  SMO=SM*SMOs(IO,itw)/dfloat(nWS*nLS) 
                  EDT0=CDEXP(im*OM1*TWI*(itw-1)) 
                  GX=(0.D0,0.D0) 
                  GY=(0.D0,0.D0) 
                  GZ=(0.D0,0.D0) 
                  DO I=1,3 
                    DO J=1,3 
                      GX=GX+ENs(I,J,itw)*UX(J,I) 
                      GY=GY+ENs(I,J,itw)*UY(J,I) 
                      GZ=GZ+ENs(I,J,itw)*UZ(J,I) 
                    end do 
                  end do 
 
                  GX0=GX*SMO*EDT*EDT0*gw(id,ngausW)*gw(ig,ngausL)/4.d0 
                  GY0=GY*SMO*EDT*EDT0*gw(id,ngausW)*gw(ig,ngausL)/4.d0 
                  GZ0=GZ*SMO*EDT*EDT0*gw(id,ngausW)*gw(ig,ngausL)/4.d0 
                  GXS(IO,IOB)=GXS(IO,IOB)+GX0 
                  GYS(IO,IOB)=GYS(IO,IOB)+GY0 
                  GZS(IO,IOB)=GZS(IO,IOB)+GZ0 
c
c      write(*,*)'io,idip,istr,id,ig ',io,idip,istr,id,ig 
c      write(*,*)'id,ngausW,ig,ngausL ',id,ngausW,ig,ngausL 
c      write(*,*)'gw*gw/4 ', gw(id,ngausW)*gw(ig,ngausL)/4.d0 
c      write(*,*)'GX ', GX 
c      write(*,*)'SMO ', SMO 
c      write(*,*)'delay+xy/vr ',delay+xy/vr 
c      write(*,*)'TWI*(itw-1),TD ',TWI*(itw-1),delay+xy/vr+TWI*(itw-1) 
c      write(*,*)'EDT ', EDT*EDT0 
c      write(*,*)'GX0 ', GX0 
c      write(*,*)'GXS ', GXS(IO,IOB) 
c      if(io.eq.1)stop 
C 
                IF(IOT.eq.1)THEN 
      write(*,*) 
      write(*,*)'Static Green Function:' 
      write(*,*)'GXS = ',GXS(io,iob) 
      write(*,*)'GYS = ',GYS(io,iob) 
      write(*,*)'GZS = ',GZS(io,iob) 
      write(*,*) 
      write(*,*)'Integrand data are stored in sint1_d & sint2_d, which' 
      write(*,*)'correspond to integration range 1 (0 - ka on the real'
      write(*,*)'k-axis) and range 2 (ka - kb & kc on the complex k-'
      write(*,*)'axis), respectively.'
      write(*,*)'Use sint1.m and sint2.m of MATLAB m-files for plotting' 
      write(*,*)'integrands of range 1 and 2, respectively.'
      write(*,*)'(See Hisada and Bielak, 2003, for more details)'  
                  CLOSE(20) 
                  CLOSE(21) 
                  stop 
                END IF 
c 
  620         CONTINUE    
  600       CONTINUE    
c 
c      write(*,*)'GXS', GXS(1,IOB) 
c 
c    * id & ig -> ngaussW & ngaussL (Gauss Points) * 
  550       CONTINUE     
  500       CONTINUE 
c 
c    * iWS & iLS -> nWS & nLS (Sub Sub-Faults) * 
  420     CONTINUE 
  400     CONTINUE 
c 
c        write(*,9992)idip,istr,ngdipS,ngstrS,ngS 
c 9992   format(' dip & str=',2i4,', Gauss Pts for W & L=',2i6
c     *        ,', Total Num=',i7)
        ngdipT=ngdipT+ngdipS 
        ngstrT=ngstrT+ngstrS 
        ngT=ngT+ngS 
c 
c    * idip & istr -> ndip & nstr (Sub Faults) * 
  320   CONTINUE 
  300   CONTINUE 
c 
c        write(*,9994)ngdipT,ngstrT
        write(*,9995)ngT   
        write(10,9994)ngdipT,ngstrT
        write(10,9995)ngT
 9994   format(' Gauss Points along Fault W & L =',2i7) 
 9995   format(' Total Number of Gauss Points on Fault  =',i7) 
        write(*,*)'Numbers of Wavenumber Integration Points for Range 1 
     *& 2 =',NWT1,NWT2 
c        write(10,*)'Numbers of Integ Pnts for Range 1 & 2 =',NWT1,NWT2
        write(*,9996)dreal(GXS(1,IOB)),dreal(GYS(1,IOB)), 
     *               dreal(GZS(1,IOB)) 
 9996   format(' Static Displacements for X, Y & Z (m) =',3e12.4) 
c 
c    * iob -> nob (Observation Points) * 
  100 CONTINUE 
c 
      RETURN 
      END 
c 
C 
C 
c 
C *** MOMENT TENSOR FOR THE SOURCE *** 
C 
      SUBROUTINE MOs(ENs,SMOs,MOM) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      DIMENSION ENs(3,3,15) 
      COMPLEX*16 SMOs(MOM,15),SMO,CPX,STT,OM,TTK,TK1,TK2
      COMMON /FREQ/DOM,IOM,NOM,OMI
      COMMON/STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                   ,VS(20),QS(20),FS(20),THK(20),NL 
     *    /FLT/STR,DIP,RAK(203,15),FL,FW,VR,FD(203,15),RT(2,15),TWI 
     *        ,xflt,yflt,zflt,delay 
     *    /IFLT/NF,NTW,IS,ngauss,ndip,nstr,iramp
C 
C *** CHECK OF DIMENSION *** 
C 
      NC=20 
      IF(NL.GE.NC)THEN 
        WRITE(*,*)' FROM ENMO:NL>NC !!!!!!!!!!' 
        WRITE(*,*)' NL,NC=',NL,NC 
        STOP 
      END IF 
C 
      NC=203 
      IF(NF.GE.NC)THEN 
        WRITE(*,*)' FROM ENMO:NF>NC !!!!!!!!!!' 
        WRITE(*,*)' NF,NC=',NF,NC 
        STOP 
      END IF 
C 
C *** SMO and EN *** 
C 
      CPX=(0.D0,1.D0) 
C 
      CST= DCOS(STR) 
      SST= DSIN(STR)  
      CDP= DCOS(DIP) 
      SDP= DSIN(DIP) 
c
      DO 100 IO=IOM,NOM+1 
c
        OM=DOM*DFLOAT(IO-1) 
c
        DO 110 itw=1,ntw  
C 
          CRK= DCOS(RAK(is,itw)) 
          SRK= DSIN(RAK(is,itw)) 
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 
          ENs(1,1,itw)= 2.D0*EX*XN 
          ENs(1,2,itw)= EX*YN +EY*XN 
          ENs(1,3,itw)= EX*ZN +EZ*XN 
          ENs(2,1,itw)= EY*XN +EX*YN 
          ENs(2,2,itw)= 2.D0*EY*YN 
          ENs(2,3,itw)= EY*ZN +EZ*YN 
          ENs(3,1,itw)= EZ*XN +EX*ZN 
          ENs(3,2,itw)= EZ*YN +EY*ZN 
          ENs(3,3,itw)= 2.D0*EZ*ZN 
c
          SMO=FD(IS,itw)*FL*FW 
          IF(OM.EQ.0.D0)THEN       
            STT= (1.D0,0.D0)       
          ELSE           
            TTK= OM*(RT(1,itw)+RT(2,itw))/2.D0 
            if(iramp.eq.0)then 
              STT= CDSIN(TTK)*CDEXP(CPX*TTK)/TTK 
            else 
              if(iramp.eq.1)then 
                TK1= OM*RT(1,itw)/2.D0 
                TK2= OM*RT(2,itw)/2.D0 
                STT= CDSIN(TK1)/TK1-CDSIN(TK2)/TK2*CDEXP(CPX*TTK) 
                STT= CPX*STT*CDEXP(CPX*TK1)/TTK 
              else 
              T0=RT(1,itw)+RT(2,itw) 
              STT=1-CPX*OM*T0 
              STT=1/(STT*STT) 
              end if 
            end if                   
          END IF 
          SMOs(IO,itw)=SMO*STT 
 110    continue
 100  continue
C 
      RETURN 
      END 
C
c
c 
C *** COMPUTATION OF Dynamic GREEN FUNCTIONS USING THE R/T METHOD *** 
C 
      SUBROUTINE HKQVWd(MOM,MOB,GXS,GYS,GZS,GGX,GGY,GGZ) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 VPc,VSc,VS2,VP2,SM,RAM 
     *      ,GGX(MOM,MOB),GGY(MOM,MOB),GGZ(MOM,MOB) 
     *      ,GXS(MOM,MOB),GYS(MOM,MOB),GZS(MOM,MOB),OM,im 
     *      ,QXG(0:2),QZG(0:2),VXG(0:2),WXG(0:2),WZG(0:2) 
     *      ,QXS(0:2),QZS(0:2),VXS(0:2),WXS(0:2),WZS(0:2) 
     *      ,SMO,EDT0,EDT,GX,GY,GZ,GX0,GY0,GZ0 
     *           ,QA,QB,VA,VB,WA,WB 
     *      ,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),gw(8,8),gaux(8,8) 
      COMMON /FREQ/DOM,IOM,NOM,OMI /OBS/XO(51),YO(51),ZO(51),NOB 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     *    /FLT/STR,DIP,RAK(203,15),FL,FW,VR,FD(203,15),RT(2,15),TWI 
     *        ,xflt,yflt,zflt,delay 
     *    /IFLT/NF,NTW,IS,ngauss,ndip,nstr,iramp  
     *    /Hypo/xhypo,yhypo,zhypo  
     *    /OTST/IOT,IST  /FCQVW/SM,RAM,RR  /SOLY/SDEP,ODEP,LS,LO 
     *    /INTG/VPMAX,VSMAX,RYMIN,CFINAL,N11,N12,M11 
     *    /WVNUM/WVN(2001),DWN,WNR(3),NWN 
c 
      data gaux(1,1)/0.0d0/ 
      data gaux(1,2),gaux(2,2) 
     * /-0.577350269189626d0, 0.577350269189626d0/ 
      data gaux(1,3),gaux(2,3),gaux(3,3) 
     * /-0.774596669241483d0,0.d0, 0.774596669241483d0/ 
      data gaux(1,4),gaux(2,4),gaux(3,4),gaux(4,4) 
     * /-0.861136311594053d0,-0.339981043584856d0 
     * , 0.339981043584856d0, 0.861136311594053d0/ 
      data gaux(1,5),gaux(2,5),gaux(3,5),gaux(4,5),gaux(5,5) 
     * /-0.906179845938664d0,-0.538469310105683d0,0.0d0 
     * , 0.538469310105683d0, 0.906179845938664d0/ 
      data gaux(1,6),gaux(2,6),gaux(3,6),gaux(4,6),gaux(5,6),gaux(6,6) 
     * /-0.932469514203152d0,-0.661209386466265d0,-0.238619186083197d0 
     * , 0.238619186083197d0, 0.661209386466265d0, 0.932469514203152d0/  
c 
      data gw(1,1) /2.d0/ 
      data gw(1,2),gw(2,2) /1.d0,1.d0/ 
      data gw(1,3),gw(2,3),gw(3,3) 
     * / 0.555555555555556d0, 0.888888888888889d0, 0.555555555555556d0/ 
      data gw(1,4),gw(2,4),gw(3,4),gw(4,4) 
     * / 0.347854845137454d0, 0.652145154862546d0 
     * , 0.652145154862546d0, 0.347854845137454d0/ 
      data gw(1,5),gw(2,5),gw(3,5),gw(4,5),gw(5,5) 
     * / 0.236926885056189d0, 0.478628670499366d0, 0.568888888888889d0 
     * , 0.478628670499366d0, 0.236926885056189d0/ 
      data gw(1,6),gw(2,6),gw(3,6),gw(4,6),gw(5,6),gw(6,6) 
     * / 0.171324492379170d0, 0.360761573048139d0, 0.467913934572691d0 
     * , 0.467913934572691d0, 0.360761573048139d0, 0.171324492379170d0/ 
C 
C *** CHECK OF DIMENSION *** 
C 
      NC=20 
      IF(NL.GE.NC)THEN 
        WRITE(10,*)' FROM HKQVW:NL>NC !!!!!!!!!!' 
        WRITE(10,*)' NL,NC=',NL,NC 
        STOP 
      END IF 
C 
      NC=51 
      IF(NOB.GE.NC)THEN 
        WRITE(10,*)' FROM HKQVW:NOB>NC !!!!!!!!!!' 
        WRITE(10,*)' NOB,NC=',NOB,NC 
        STOP 
      END IF 
C 
      NC=MOB 
      IF(NOB.GE.NC)THEN 
        WRITE(10,*)' FROM HKQVW:NOB>MOB !!!!!!!!!!' 
        WRITE(10,*)' NOB,NC=',NOB,MOB 
        STOP 
      END IF 
C 
      NC=203 
      IF(NF.GE.NC)THEN 
        WRITE(10,*)' FROM HKQVW:NF>NC !!!!!!!!!!' 
        WRITE(10,*)' NF,NC=',NF,NC 
        STOP 
      END IF 
C 
C *** GREEN'S FUNCTION *** 
C 
C   * output of integrands for check * 
C 
      write(*,*)'From HKQVWd:'
      write(*,*)'Please choose the following combinations of integrands' 
      write(*,*)' 0: Regular (= Dynamic Integrand - Static Integrand)' 
      write(*,*)' 1: Dynamic (= Dynamic Integrand)' 
      write(*,*)' 2: Static (= Static Integrand, checking purpose only)' 
      write(*,*)'(Enter 1, if the fault is deep. It is faster.)'
      read(*,*)IST 
C 
      write(*,*) 
      write(*,*)'Output Dynamic Integrands?'
      write(*,*)'  Enter 0 for No  (Regular)' 
      write(*,*)'  Enter 1 for YES (Checking Purpose Only)' 
      read(*,*)IOT  
c 
      IF(IOT.eq.1)THEN 
        write(*,*)'  The first observation point is used as the source l
     *ocation.' 
        write(*,2000)xo(1),yo(1),zo(1) 
 2000   format('   Source Location (x,y,z: m)=',3f12.4) 
        write(*,*)'  Enter the location of Observation Point (x,y,z: m)' 
        read(*,*)xot,yot,zot 
        OPEN (30,FILE='dint_d',STATUS='unknown') 
C 
        df0=dom/6.283185307d0 
        f1=0.d0 
        f2=df0*nom 
        write(*,*) 
        write(*,*)'Available Frequency Range (Hz) =',f1,f2 
        write(10,*)'Available Frequency Range (Hz) =',f1,f2 
        write(*,*)'Enter Output Frequency (Hz)' 
        read(*,*)ofreq 
        df=9999.d0 
        do i=1,nom+1 
          freq=df0*(i-1) 
          dfreq=dabs(freq-ofreq) 
          if(dfreq.lt.df)then 
            ioutom=i 
            df=dfreq 
          end if 
        end do 
        write(*,*)'Actual Output Frequency (Hz) =',df0*(ioutom-1) 
        write(10,*)'Actual Output Frequency (Hz) =',df0*(ioutom-1) 
      END IF 
C 
      write(*,*) 
      write(*,*)'Use Dynamic Distribution of Gaussian Points on Fault?'
      write(*,*)'  Enter 0 for No  (Regular. Num. of Points are fixed)' 
      write(*,*)'  Enter 1 for YES (Faster, but may lose accuracy)' 
      read(*,*)IGS
C 
c   * Green's function computations * 
c 
      im=DCMPLX(0.d0,1.d0) 
      dcs=FW*dcos(dip) 
      cst=dcos(str) 
      sst=dsin(str) 
c 
      write(10,*)
      write(10,*)'from HKQVW:'
      DO 100 IO=IOM,NOM+1
C 
        if((iot.eq.1).and.(io.ne.ioutom))goto 100 
c 
        if(io.eq.1)then 
      write(*,*) 
          do IOB=1,NOB 
      write(*,*)'static, dynamic & total (io,iob)',io,iob 
            GGX(IO,IOB)=GXS(IO,IOB) 
            GGY(IO,IOB)=GYS(IO,IOB) 
            GGZ(IO,IOB)=GZS(IO,IOB) 
      write(*,*)'GGX',GGX(io,iob) 
          end do 
          goto 100 
        end if 
c 
        OMR=DOM*DFLOAT(IO-1) 
        OM=dcmplx(OMR,OMI) 
        freq=omr/6.2831853072d0 
C 
c     * Configure wavenumbers for numerical integrations * 
c 
c       * range 1: from near 0 to near om/Rayleigh(min) * 
        WNR(2)=OMR/rymin*1.2d0
        WNR(1)=WNR(2)/n11/10000.d0 
        CALL WVNUMV(MOM,IO,dreal(OM)) 
c 
        NWN=2*(M11+N12)+1 
        NC=2001 
        IF(NWN.GT.NC)THEN 
          WRITE(10,*)'FROM HKQVWd: NWN > 2001 !!!' 
        STOP 
        END IF 
C 
c       * range 2: from near om/Rayleigh(min) to near om/C(final) * 
        WNR(3)=OMR/cfinal 
        DWN=(WNR(3)-WNR(2))/(2.D0*N12) 
        DO 150 K=1,2*N12+1 
          WVN(2*M11+K)=WNR(2)+DWN*(K-1) 
 150    CONTINUE 
c 
c        write(*,*)
        write(*,1005)om,nwn 
        write(10,*) 
        write(10,1005)om,nwn 
        write(10,1010)wnr(1),wnr(2),wnr(3) 
        write(10,1020)dwn 
 1005   format(' Omega, Num. of Wave-number integ. points =',2f10.4,I6) 
 1010   format(' Boundaries for the Integration ranges:',3e12.4) 
 1020   format(' Integration Increments for Range 2:',e12.4) 
C 
c     * the observation points * 
c 
        DO 200 IOB=1,NOB 
C 
          GGX(IO,IOB)=(0.D0,0.D0) 
          GGY(IO,IOB)=(0.D0,0.D0) 
          GGZ(IO,IOB)=(0.D0,0.D0) 
c 
          ZS=ZO(IOB) 
          if(iob.ge.2)then 
            if(zs.eq.zo(iob-1))goto 10 
          end if 
 
          DRU=0.d0
          DRL=THK(1) 
          DO 220 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) 
 220     CONTINUE 
C 
          DEP1=0.d0
          DO 230 L=1,LS-1 
            DEP1=DEP1+THK(L) 
 230      CONTINUE 
          SDEP=ZS-DEP1 
C
c       * Configure the up/down-going coefficient library * 
c 
          CALL CUDSH(OM) 
          CALL CUDPSV(OM) 
          CALL CUDSH0(dcmplx(0.d0,OMI)) 
          CALL CUDPSV0(dcmplx(0.d0,OMI)) 
c 
c       * fault points and Green's function computation  * 
c 
 10       DO 300 idip=1,ndip  
c  
            ngausL=ngauss 
            ngausW=ngauss 
c 
            da=dcs*(idip-1) 
            db=dcs*idip 
            za=zflt-da*dtan(dip)*1.0000001d0 
            zb=zflt-db*dtan(dip)*0.9999999d0 
            if(zb.lt.0.d0)then 
              write(*,*)'Fault Depth is less than 0!: Dip Number=',idip 
              stop 
            end if 
            DRU=0.d0
            DRL=THK(1) 
            do L=1,NL 
              IF((za.GE.DRU).AND.(za.LT.DRL))L1=L 
              IF((za.GE.DRU).AND.(L.EQ.NL))  L1=L 
              DRU=DRL 
              DRL=DRL+THK(L+1) 
            end do 
            DRU=0.d0
            DRL=THK(1) 
            do L=1,NL 
              IF((zb.GE.DRU).AND.(zb.LT.DRL))L2=L 
              IF((zb.GE.DRU).AND.(L.EQ.NL))  L2=L 
              DRU=DRL 
              DRL=DRL+THK(L+1) 
            end do 
            if(L1.ne.L2)then 
              write(*,*)' The L1 Layer is different from the L2 Layer!' 
              write(*,*)' Layers 1 and 2 =',L1,L2 
c             stop 
            end if 
c 
            if(IGS.eq.0)goto 17 
c             
            Vmin=Vs(L1) 
            if(Vs(L2).lt.Vmin)Vmin=Vs(L2) 
            if(VR.lt.Vmin)Vmin=VR 
            if(omr.lt.0.00001d0)then 
              wvlen=Vmin*6.283185307d0/0.000001d0 
            else 
              wvlen=Vmin*6.283185307d0/OMR 
            end if 
c 
            gausW=FW*ngauss/wvlen 
            ngausW=1 
            if(gausW.gt.0.7d0)then 
              ngausW=2 
              if(gausW.gt.2.0d0)then 
                ngausW=3 
                if(gausW.gt.3.0d0)then 
                  ngausW=4 
                  if(gausW.gt.5.0d0)then 
                    ngausW=5 
                    if(gausW.gt.6.4d0)then 
                      ngausW=6 
                      if(gausW.gt.6.0d0)then 
                  write(*,*)'ngausW > 6 !!!!; Use smaller sub-faults!' 
                  write(*,*)'ngausW > 6 -> ngausW = 6' 
                        ngausW=6 
                      end if 
                    end if 
                  end if 
                end if 
              end if 
            end if 
c 
            gausL=FL*ngauss/wvlen 
            ngausL=1 
            if(gausL.gt.0.7d0)then 
              ngausL=2 
              if(gausL.gt.2.0d0)then  
                ngausL=3 
                if(gausL.gt.3.0d0)then 
                  ngausL=4 
                  if(gausL.gt.5.0d0)then 
                    ngausL=5 
                    if(gausL.gt.6.4d0)then 
                      ngausL=6 
                      if(gausL.gt.6.0d0)then 
                  write(*,*)'ngausL > 6 !!!!; Use smaller sub-faults!' 
                  write(*,*)'ngausL > 6 -> ngausL = 6' 
                        ngausL=6 
                      end if 
                    end if 
                  end if 
                end if 
              end if 
            end if 
 
          if(iob.eq.1)then
            write(*,1200)idip,za,zb          
            write(*,1210)gausW,ngausW 
            write(*,1220)gausL,ngausL 
            write(10,1200)idip,za,zb          
            write(10,1210)gausW,ngausW 
            write(10,1220)gausL,ngausL 
          end if 
 1200     format('  Elem Num.for W, and the edge depths =',i3,2f10.2) 
 1210     format('  Gauss Points per Sub-Fault along W =',f9.2,' ->',i3) 
 1220     format('  Gauss Points per Sub-Fault along L =',f9.2,' ->',i3) 
c 
 17         DO 300 istr=1,nstr 
c 
            IS=nstr*(idip-1)+istr 
            sa=FL*(istr-1) 
            sb=FL*istr 
c 
            do itw=1,ntw 
              if(FD(IS,itw).ne.0.d0)goto 20 
            end do 
            goto 300 
 20         continue 
c 
c           * Gaussian Quadrature (id*ig points) * 
c 
            do 400 id=1,ngausW 
c 
              zd=((1.d0-gaux(id,ngausW))*za 
     *           +(1.d0+gaux(id,ngausW))*zb)/2.d0 
              if(iot.eq.1)zd=zot 
   
              DRU=0.d0
              DRL=THK(1) 
              do L=1,NL 
                IF((zd.GE.DRU).AND.(zd.LT.DRL))L1=L 
                IF((zd.GE.DRU).AND.(L.EQ.NL))  L1=L 
                DRU=DRL 
                DRL=DRL+THK(L+1) 
              end do 
              zz=zd-zhypo 
 
              LO=L1 
              QPe=FuncQP(OM,LO)
              QSe=FuncQS(OM,LO)
              VPc=VP(LO)*DCMPLX(1.D0,-0.5D0/QPe) 
              VSc=VS(LO)*DCMPLX(1.D0,-0.5D0/QSe) 
              VP2= VPc*VPc 
              VS2= VSc*VSc 
              SM = DNS(LO)*VS2 
              RAM= DNS(LO)*VP2-2.D0*SM 
C 
              ZZO=zd 
              ODEP=ZZO 
              DO L=2,LO 
                ODEP=ODEP-THK(L-1) 
              end do 
C 
              dd=((1.d0-gaux(id,ngausW))*da 
     *           +(1.d0+gaux(id,ngausW))*db)/2.d0 
      
              do 450 ig=1,ngausL 
 
                sg=((1.d0-gaux(ig,ngausL))*sa 
     *             +(1.d0+gaux(ig,ngausL))*sb)/2.d0 
                XF=xflt+sg*cst+dd*sst 
                YF=yflt+sg*sst-dd*cst 
                xx=XF-xhypo 
                yy=YF-yhypo 
                xy=dsqrt(xx*xx+yy*yy+zz*zz) 
                TD=delay+xy/vr             
              if(iot.eq.1)then 
                XF=xot 
                YF=yot 
                  TD=0.d0             
              end if 
                RX=XF-XO(IOB) 
                RY=YF-YO(IOB) 
                RR=DSQRT(RX*RX+RY*RY) 
c 
                EDT=CDEXP(im*OM*TD) 
C 
                DO J=0,2 
                  QXS(J)=(0.D0,0.D0) 
                  VXS(J)=(0.D0,0.D0) 
                  WXS(J)=(0.D0,0.D0) 
                  QZS(J)=(0.D0,0.D0) 
                  WZS(J)=(0.D0,0.D0) 
                  QXG(J)=(0.D0,0.D0) 
                  VXG(J)=(0.D0,0.D0) 
                  WXG(J)=(0.D0,0.D0) 
                  QZG(J)=(0.D0,0.D0) 
                  WZG(J)=(0.D0,0.D0) 
                end do 
c 
c         * the wavenumber integration using Simpson's and Filon's fomulas * 
                CALL QVWRZS0(OM,QXS,QZS,VXS,WXS,WZS) 
                CALL QVWRZF0(OM,QXG,QZG,VXG,WXG,WZG) 
c 
c      write(*,*)'xf,yf,zd ',xf,yf,zd 
c      write(*,*)'rx,ry,rr ',rx,ry,rr 
c      write(*,*)'om ',om 
c      write(*,*)'QX0 ',QXS(0),QXG(0) 
c      write(*,*)'QX1 ',QXS(1),QXG(1) 
c      write(*,*)'QX2 ',QXS(2),QXG(2) 
c      write(*,*)'VX1 ',VXS(1),VXG(1) 
c      write(*,*)'VX2 ',VXS(2),VXG(1) 
c      stop 
c 
c         * see Hisada(1994) eq.(26) * 
                CR=RX/RR 
                SR=RY/RR 
                C2=CR*CR 
                S2=SR*SR 
                CS=CR*SR 
                CX=S2/RR 
                SY=C2/RR 
                CY=-CS/RR 
                SX=CY 
C        
c         * Urx, Ury, Urz: see Hisada(1994) eq.(11) * 
                QA=QXG(0)+QXS(0) 
                  QX(0)=QA*CR 
                  QY(0)=QA*SR 
                  QZ(0)=-(QZG(0)+QZS(0)) 
C 
c         * Utx, Uty     : see Hisada(1994) eq.(11) * 
                VA=VXG(0)+VXS(0) 
                  VX(0)=-VA*SR 
                  VY(0)= VA*CR 
C              
c         * Uzx, Uzy, Uzz: see Hisada(1994) eq.(11) * 
                WA=WXG(0)+WXS(0) 
                  WX(0)=-WA*CR 
                  WY(0)=-WA*SR 
                  WZ(0)=-(WZG(0)+WZS(0)) 
c              
c         * Urx,x, Ury,x, Urx,y, Ury,y, Urz,x Urz,y: see Hisada(1994) eq.(27) * 
                QB=QXG(1)+QXS(1) 
                  QX(1)=QB*C2+QA*CX 
                  QY(1)=QB*CS+QA*SX 
                  QX(2)=QB*CS+QA*CY 
                  QY(2)=QB*S2+QA*SY 
                QB=QZG(1)+QZS(1) 
                  QZ(1)=-QB*CR 
                  QZ(2)=-QB*SR 
c 
c         * Utx,x, Uty,x, Utx,y, Uty,y: see Hisada(1994) eq.(27) * 
                VB=VXG(1)+VXS(1) 
                  VX(1)=-(VB*CS+VA*SX) 
                  VY(1)=  VB*C2+VA*CX 
                  VX(2)=-(VB*S2+VA*SY) 
                  VY(2)=  VB*CS+VA*CY 
c     
c         * Uzx,x, Uzy,x, Uzx,y, Uzy,y, Uzz,x Uzz,y: see Hisada(1994) eq.(27)  
                WB=WXG(1)+WXS(1) 
                  WX(1)=-(WB*C2+WA*CX) 
                  WY(1)=-(WB*CS+WA*SX) 
                  WX(2)=-(WB*CS+WA*CY) 
                  WY(2)=-(WB*S2+WA*SY) 
                WB=WZG(1)+WZS(1) 
                  WZ(1)=-WB*CR 
                  WZ(2)=-WB*SR 
c 
c         * Urx,z, Ury,z, Urz,z: see Hisada(1994) eq.(29) * 
                QB=QXG(2)+QXS(2) 
                  QX(3)= QB*CR 
                  QY(3)= QB*SR 
                  QZ(3)=-(QZG(2)+QZS(2)) 
c              
c         * Utx,z, Uty,z: see Hisada(1994) eq.(29) * 
                VB=VXG(2)+VXS(2) 
                  VX(3)=-VB*SR 
                  VY(3)= VB*CR 
c            
c         * Uzx,z, Uzy,z, Uzz,z: see Hisada(1994) eq.(29) * 
                WB=WXG(2)+WXS(2) 
                  WX(3)=-WB*CR 
                  WY(3)=-WB*SR 
                  WZ(3)=-(WZG(2)+WZS(2)) 
C              
c         * Uxx,x, Uxx,y, Uxy,x, Uxy,y, Uxz,x, Uxz,y: see Hisada(1994) eq.(24) * 
                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        
c         * Uyx,x, Uyx,y, Uyy,x, Uyy,y, Uyz,x, Uyz,y: see Hisada(1994) eq.(24) * 
                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 
c         * Uzx,x, Uzx,y, Uzy,x, Uzy,y, Uzz,x, Uzz,y: see Hisada(1994) eq.(27) * 
                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 
c         * Uxx,z, Uxy,z, Uxz,z, Uyx,z, Uyy,z, Uyz,z: see Hisada(1994) eq.(25) * 
                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 
C 
c         * Uzx,z, Uzy,z, Uzz,z: see Hisada(1994) eq.(29) * 
                UX(3,3)=WX(3) 
                UY(3,3)=WY(3) 
                UZ(3,3)=WZ(3) 
c 
c               * Time Windows * 
c 
                do 470 itw=1,ntw 
c 
                  CALL MO(itw,OM,en,SMO) 
                  EDT0=CDEXP(im*OM*TWI*(itw-1)) 
                  GX=(0.D0,0.D0) 
                  GY=(0.D0,0.D0) 
                  GZ=(0.D0,0.D0) 
                  DO I=1,3 
                  DO J=1,3 
                    GX=GX+EN(I,J)*UX(J,I) 
                    GY=GY+EN(I,J)*UY(J,I) 
                    GZ=GZ+EN(I,J)*UZ(J,I) 
c      write(*,*)'i,j,UX',i,j,UX(J,I) 
                  end do 
                  end do 
                  GX0=GX*SMO*EDT*EDT0*gw(id,ngausW)*gw(ig,ngausL)/4.d0 
                  GY0=GY*SMO*EDT*EDT0*gw(id,ngausW)*gw(ig,ngausL)/4.d0 
                  GZ0=GZ*SMO*EDT*EDT0*gw(id,ngausW)*gw(ig,ngausL)/4.d0 
c 
                  GGX(IO,IOB)=GGX(IO,IOB)+GX0 
                  GGY(IO,IOB)=GGY(IO,IOB)+GY0 
                  GGZ(IO,IOB)=GGZ(IO,IOB)+GZ0 
c 
c      if(io.eq.20)then 
c      write(*,*)'io,idip,istr,id,ig ',io,idip,istr,id,ig 
c      write(*,*)'GX ', GX 
c      write(*,*)'id,ngausW,ig,ngausL ', id,ngausW,ig,ngausL  
c      write(*,*)'gw(id,nW),gw(ig,nL) ', gw(id,ngausW),gw(ig,ngausL)  
c      write(*,*)'SMO ', SMO 
c      write(*,*)'TD,TDT ',TD,TD+TWI*(itw-1) 
c      write(*,*)'EDT ', EDT*EDT0 
c      write(*,*)'GX0', GX0 
c      write(*,*)'GXS', GXS(IO,IOB) 
c      stop 
c      end if 
c      if(io.eq.2)stop 
c 
                IF(IOT.eq.1)THEN 
                  CLOSE(30) 
      write(*,*)
      write(*,*)'Dynamic Green function:'
      write(*,*)'GX0',GX0 
      write(*,*)'GY0',GY0 
      write(*,*)'GZ0',GZ0 
      write(*,*) 
      write(*,*)'Integrand data are stored in dint_d.' 
      write(*,*)'dint.m of MATLAB plots the Green function integrands' 
      stop 
                END IF 
c 
  470           CONTINUE 
c 
  450         CONTINUE 
c     
  400       CONTINUE 
c 
  300     CONTINUE 
c 
c      write(*,*)'static, dynamic & total (io,iob) ',io,iob
c      write(*,*)'GXS',GXS(io,iob)
c      write(*,*)'GGX',GGX(io,iob)
          GGX(IO,IOB)=GGX(IO,IOB)+GXS(IO,IOB) 
          GGY(IO,IOB)=GGY(IO,IOB)+GYS(IO,IOB) 
          GGZ(IO,IOB)=GGZ(IO,IOB)+GZS(IO,IOB) 
c      write(*,*)'GGX',GGX(io,iob)
c 
  200   CONTINUE 
c 
c      if(io.eq.20)stop 
C 
  100 CONTINUE 
C 
      RETURN 
      END 
c 
C 
c 
C *** INPUT OF Pole and Branch Points *** 
C 
      SUBROUTINE PHSBRC(MOM) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      dimension CR(531,0:201),CL(531,0:201),MDL(531),MDR(531) 
      COMMON /FREQ/DOM,IOM,NOM,OMI /POLE/CS(531,201),NW(531) 
     *       /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                    ,VS(20),QS(20),FS(20),THK(20),NL 
     *       /TMP1/CC(201) 
C 
C  ** CHECK **  
C 
      NC=531 
      IF(MOM.GT.NC)THEN 
         WRITE(10,*)'FROM PHSBRC: MOM>NC !!' 
         STOP 
      END IF 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)'FROM PHSBRC: NL>NC !!' 
         STOP 
      END IF 
 
c   * Number of Poles in Common Block * 
      NC=201 
c 
C  ** INPUT OF PHASE VELOCITIES FOR LOVE AND RAYLEIGH MODES ** 
C 
      open(22,file='mdl_dat',status='old') 
      open(23,file='mdr_dat',status='old') 
      DO 100 IO=IOM,NOM+1 
        READ(22,*)MDL(IO) 
        READ(23,*)MDR(IO) 
        IF(MDL(IO).GT.NC)THEN 
         WRITE(10,*)'FROM PHSBRC: MDL>NC !!' 
         STOP 
        END IF 
        IF(MDR(IO).GT.NC)THEN 
         WRITE(10,*)'FROM PHSBRC: MDR>NC !!' 
         STOP 
        END IF 
  100 CONTINUE 
      close(22) 
      close(23) 
 
      open(25,file='phsl1_dat',status='old')
      open(26,file='phsr1_dat',status='old')
      DO 120 IO=IOM,NOM+1
        DO 110 MD=0,MDL(io)
          read(25,*)CL(IO,MD)
  110   CONTINUE
        DO 115 MD=0,MDR(io)
          read(26,*)CR(IO,MD)
  115   CONTINUE
  120 CONTINUE
      close(25)
      close(26)
C 
C  ** CONSTRUCT PHASE VELOCITY DATA ** 
C 
      write(10,1000) 
 1000 FORMAT(//' From PHSBRC:') 
 
      DO 200 IO=IOM,NOM+1 
 
        IF(NL.EQ.1)THEN 
          N=1 
          CC(N)=CR(IO,0) 
          GOTO 210 
        END IF 
C 
        N=0 
        IR=0 
        IL=0 
c 
    5   N=N+1 
        if((CR(IO,IR).lt.CL(IO,IL)).and.(CR(IO,IR).ne.0.d0))then 
          CC(N)=CR(IO,IR) 
          IR=IR+1 
        else 
          IF((CL(IO,IL).EQ.0.D0).AND.(CR(IO,IR).NE.0.D0))THEN 
            CC(N)=CR(IO,IR) 
            IR=IR+1 
          ELSE 
            if(CL(IO,IL).ne.0.d0)then 
              CC(N)=CL(IO,IL) 
              IL=IL+1 
            else 
              N=N-1 
              GOTO 210 
            end if 
          end if 
        end if 
 
        if((IR.le.MDR(IO)).or.(IL.le.MDL(IO)))goto 5 
c 
 210    NW(IO)=N+NL*2 
c 
        NC=201 
        IF(NW(IO).GE.NC)THEN 
          WRITE(10,*)' FROM PHSBRC: NW.GE.NC !!, IO',IO 
          STOP 
        END IF 
C 
        DO 220 I=1,N-1 
          IF(CC(I).EQ.0.D0)THEN 
            WRITE(10,*)' FROM PHSBRC: CS=0 !!, IO',IO 
            STOP 
          END IF 
          IF(CC(I).GT.CC(I+1))THEN 
            WRITE(10,*)' FROM PHSBRC: CS(I)>CS(I+1) !!, IO',IO 
            STOP 
          END IF 
  220   CONTINUE 
        IF(CC(N).EQ.0.D0)THEN 
          WRITE(10,*)' FROM PHSBRC: CS=0 !!, IO',IO 
          STOP 
        END IF 
c 
        ib=0 
        do 300 IL=1,NL 
          VSR=VS(IL) 
          VPR=VP(IL) 
          is=0 
          i=1 
          C1=CC(i) 
          if(VSR.lt.C1)then 
            do ii=NW(IO),i+1,-1 
              CC(ii)=CC(ii-1) 
             end do 
            CC(i)=VSR 
            is=1 
            ib=ib+1 
            goto 20 
          end if             
   10     i=i+1 
          C2=CC(i) 
          if(C2.eq.0.d0)goto 20 
          if(VSR.lt.C2)then 
            do ii=NW(IO),i+1,-1 
              CC(ii)=CC(ii-1) 
            end do 
            CC(i)=VSR 
            is=1 
            ib=ib+1 
            goto 20 
          end if 
          goto 10 
c           
   20     if(is.eq.0)then 
            CC(N+ib+1)=VSR 
            ib=ib+1 
          end if 
c           
          ip=0 
          i=1 
   30     i=i+1 
          C2=CC(i) 
          if(C2.eq.0.d0)goto 40 
          if(VPR.lt.C2)then 
            do ii=NW(IO),i+1,-1 
              CC(ii)=CC(ii-1) 
            end do 
            CC(i)=VPR 
            ip=1 
            ib=ib+1 
            goto 40 
          end if 
          goto 30 
c           
   40     if(ip.eq.0)then 
            CC(N+ib+1)=VPR 
            ib=ib+1 
          end if 
           
  300   continue 
c           
        do i=1,nw(io) 
          CS(IO,i)=CC(i) 
          cc(i)=0.d0 
        end do 
c 
        write(10,1100)(io-1)*dom,nw(io) 
        write(10,1110) 
        do 320 i=1,NW(IO),5 
          write(10,1120)CS(IO,i),CS(IO,i+1) 
     *               ,CS(IO,i+2),CS(IO,i+3),CS(IO,i+4) 
  320   continue 
 1100   FORMAT('Omega, Number of Phase Velocities=',f8.5,I5) 
 1110   FORMAT('Phase Velocities of Poles and Branch Points (m/s)=') 
 1120   FORMAT(2x,5D12.4) 
C 
        DO 340 I=1,NW(IO)-1 
          IF(CS(IO,I).EQ.0.D0)THEN 
            WRITE(10,*)' FROM PHSBRC: CS=0 !!' 
            WRITE(*,*)' FROM PHSBRC: CS=0 !!' 
            STOP 
          END IF 
          IF(CS(IO,I).GT.CS(IO,I+1))THEN 
            WRITE(10,*)' FROM PHSBRC: CS(I)>CS(I+1) !!' 
            WRITE(*,*)' FROM PHSBRC: CS(I)>CS(I+1) !!' 
            STOP 
          END IF 
  340   CONTINUE 
        IF(CS(IO,N).EQ.0.D0)THEN 
          WRITE(10,*)' FROM PHSBRC: CS=0 !!' 
          WRITE(*,*)' FROM PHSBRC: CS=0 !!' 
          STOP 
        END IF 
c 
  200 continue 
C 
      RETURN 
      END 
C 
c 
C *** MOMENT TENSOR FOR THE SOURCE *** 
C 
      SUBROUTINE MO(itw,OM,en,SMO) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      DIMENSION EN(3,3) 
      COMPLEX*16 SMO,CPX,SM,RAM,STT,OM,TTK,TK1,TK2 
      COMMON/STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                   ,VS(20),QS(20),FS(20),THK(20),NL 
     *    /FLT/STR,DIP,RAK(203,15),FL,FW,VR,FD(203,15),RT(2,15),TWI 
     *        ,xflt,yflt,zflt,delay 
     *    /IFLT/NF,NTW,IS,ngauss,ndip,nstr,iramp 
     *    /FCQVW/SM,RAM,RR  
C 
C *** CHECK OF DIMENSION *** 
C 
      NC=20 
      IF(NL.GE.NC)THEN 
        WRITE(*,*)' FROM ENMO:NL>NC !!!!!!!!!!' 
        WRITE(*,*)' NL,NC=',NL,NC 
        STOP 
      END IF 
C 
      NC=203 
      IF(NF.GE.NC)THEN 
        WRITE(*,*)' FROM ENMO:NF>NC !!!!!!!!!!' 
        WRITE(*,*)' NF,NC=',NF,NC 
        STOP 
      END IF 
C 
      CPX=(0.D0,1.D0) 
c 
C *** EN *** 
C 
      CST= DCOS(STR) 
      SST= DSIN(STR) 
C 
      CDP= DCOS(DIP) 
      SDP= DSIN(DIP) 
C 
      CRK= DCOS(RAK(is,itw)) 
      SRK= DSIN(RAK(is,itw)) 
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.D0*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.D0*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.D0*EZ*ZN 
C 
C *** SMO *** 
C 
      SMO= FD(IS,itw)*SM*FL*FW 
C 
      IF(dreal(OM).EQ.0.D0)THEN       
        STT= (1.D0,0.D0)       
      ELSE           
        TTK= OM*(RT(1,itw)+RT(2,itw))/2.D0 
        if(iramp.eq.0)then 
          STT= CDSIN(TTK)*CDEXP(CPX*TTK)/TTK 
        else 
          if(iramp.eq.1)then 
            TK1= OM*RT(1,itw)/2.D0 
            TK2= OM*RT(2,itw)/2.D0 
            STT= CDSIN(TK1)/TK1-CDSIN(TK2)/TK2*CDEXP(CPX*TTK) 
            STT= CPX*STT*CDEXP(CPX*TK1)/TTK 
          else 
          T0=RT(1,itw)+RT(2,itw) 
          STT=1-CPX*OM*T0 
          STT=1/(STT*STT) 
          end if 
        end if                   
      END IF 
C 
c      SMO=CPX*SMO*STT/OM 
c      write(*,*)'stt',stt 
      SMO=SMO*STT 
C 
      RETURN 
      END 
c 
c 
C *** CONSTRUCT POINTS FOR WAVENUMBER INTEGRATION *** 
C 
      SUBROUTINE WVNUMV(MOM,IO,OM) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMMON /INTG/VPMAX,VSMAX,RYMIN,CFINAL,N11,N12,M11 
     *       /WVNUM/WVN(2001),DWN,WNR(3),NWN 
     *       /POLE/CS(531,201),NW(531) /TMP/WVT(1001) 
C 
C  ** CHECK **  
C 
      NC=531 
      IF(MOM.GT.NC)THEN 
         WRITE(10,*)'FROM WVNUM: MOM > NC !!' 
         STOP 
      END IF 
C 
      NC=201 
      IF(NW(IO).GT.NC)THEN 
         WRITE(10,*)'FROM WVNUM: NW(IO) > NC !!' 
         STOP 
      END IF 
C 
      NC=1001 
      IF((N11+1+NW(IO)*9).GT.NC)THEN 
         WRITE(10,*)'FROM WVNUM: N11+1+NW(IO)*9 > NC !!' 
         STOP 
      END IF 
C 
C  ** POINTS ** 
C 
      DW1=(WNR(2)-WNR(1))/N11 
      DO 100 K=1,N11+1 
        WVT(K)=WNR(1)+DW1*(K-1) 
 100  CONTINUE 
c 
      MW=N11 
      DW=DW1/16.D0 
      DO 200 J=1,NW(IO) 
        POLE=OM/CS(IO,J) 
        IPL=0 
        DO 210 K=1,NW(IO) 
          PL1=OM/CS(IO,K) 
          DP1=PL1-POLE 
          IF((DABS(DP1).LT.DW).AND.(DP1.GT.0.D0))IPL=1 
 210    CONTINUE 
c 
        IF(IPL.EQ.0)THEN 
          W1=POLE-DW1/2.D0 
          CALL WVNM(W1,MW) 
          W2=POLE-DW1/4.D0 
          CALL WVNM(W2,MW) 
          W3=POLE-DW1/8.D0 
          CALL WVNM(W3,MW) 
          W4=POLE-DW1/16.D0 
          CALL WVNM(W4,MW) 
          W5=POLE 
          CALL WVNM(W5,MW) 
          W6=POLE+DW1/16.D0 
          CALL WVNM(W6,MW) 
          W7=POLE+DW1/8.D0 
          CALL WVNM(W7,MW) 
          W8=POLE+DW1/4.D0 
          CALL WVNM(W8,MW) 
          W9=POLE+DW1/2.D0 
          CALL WVNM(W9,MW) 
        ELSE 
          CALL WVNM(POLE,MW) 
        END IF 
 200  CONTINUE 
c 
      DW=DW1/16.D0*0.9999D0 
      DR=DW/1000.D0 
      DO 300 I=1,MW 
        WA=WVT(I) 
        WB=WVT(I+1) 
        WD=WB-WA 
        ISML=0 
        IF(WD.LT.DW)THEN 
          ISML=1 
          DO 310 J=1,NW(IO) 
            POLE=OM/CS(IO,J) 
            IF((DABS(WA-POLE).LT.DR).OR.(DABS(WB-POLE).LT.DR))ISML=0 
 310      CONTINUE 
          IF(DABS(WB-WNR(2)).LT.DR)ISML=0 
        END IF 
        IF(ISML.EQ.1)THEN 
          DO 320 K=I+1,MW 
            WVT(K)=WVT(K+1) 
 320      CONTINUE 
          MW=MW-1 
        END IF 
 300  CONTINUE 
c 
      DO 400 J=1,MW 
        WVN(2*J-1)=WVT(J) 
        WVN(2*J  )=(WVT(J)+WVT(J+1))/2.D0 
 400  CONTINUE 
      WVN(2*MW+1)=WVT(MW+1) 
c 
      M11=MW 
c 
      return 
      end 
C 
C 
      SUBROUTINE WVNM(W,MW) 
      implicit real*8(a-h,o-z) 
      COMMON /TMP/WVT(1001)  
C 
      DO 100 I=1,MW 
        WA=WVT(I) 
        WB=WVT(I+1) 
        IF((W.GT.WA).AND.(W.LT.WB))THEN 
          DO 105 K=MW+1,I+1,-1 
            WVT(K+1)=WVT(K) 
 105      CONTINUE 
          WVT(I+1)=W 
          MW=MW+1 
          RETURN 
        END IF 
 100  CONTINUE 
c 
      RETURN 
      END 
c 
C 
C *** THE COMPUTATION OF Q, V, AND W AND THEIR DERIVATIVES  
C     USING Newton-Cotes Quadrature (for Static Range 1: k0 - ka on real k axis)*** 
C 
      SUBROUTINE QVWRZS1(OM,GQX,GQZ,GVX,GWX,GWZ) 
C      
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 GQX(0:2),GQZ(0:2),GVX(0:2),GWX(0:2),GWZ(0:2) 
     *          ,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) 
     *          ,QX3(0:2),QZ3(0:2),VX3(0:2),WX3(0:2),WZ3(0:2) 
     *          ,QX4(0:2),QZ4(0:2),VX4(0:2),WX4(0:2),WZ4(0:2) 
     *          ,QX5(0:2),QZ5(0:2),VX5(0:2),WX5(0:2),WZ5(0:2) 
     *          ,QX6(0:2),QZ6(0:2),VX6(0:2),WX6(0:2),WZ6(0:2) 
     *          ,QX7(0:2),QZ7(0:2),VX7(0:2),WX7(0:2),WZ7(0:2) 
     *          ,QX8(0:2),QZ8(0:2),VX8(0:2),WX8(0:2),WZ8(0:2) 
     *          ,QX9(0:2),QZ9(0:2),VX9(0:2),WX9(0:2),WZ9(0:2) 
     *          ,QX10(0:2),QZ10(0:2),VX10(0:2),WX10(0:2),WZ10(0:2) 
     *          ,QX11(0:2),QZ11(0:2),VX11(0:2),WX11(0:2),WZ11(0:2) 
     *          ,QX12(0:2),QZ12(0:2),VX12(0:2),WX12(0:2),WZ12(0:2) 
     *          ,QX13(0:2),QZ13(0:2),VX13(0:2),WX13(0:2),WZ13(0:2) 
     *          ,QX14(0:2),QZ14(0:2),VX14(0:2),WX14(0:2),WZ14(0:2) 
     *          ,QX15(0:2),QZ15(0:2),VX15(0:2),WX15(0:2),WZ15(0:2) 
     *          ,QX16(0:2),QZ16(0:2),VX16(0:2),WX16(0:2),WZ16(0:2) 
     *          ,QX17(0:2),QZ17(0:2),VX17(0:2),WX17(0:2),WZ17(0:2) 
     *          ,OM,SM,RAM,aa 
      COMMON /WVNUMs/WNRs(3),NWN1o,NWN2o,NWN1,NWN2,NWT1,NWT2 
     *    /OTST/IOT,IST  /FCQVW/SM,RAM,RR  /SOLY/SDEP,ODEP,LS,LO 
C 
C   *Newton-Cotes Quadrature (for Static Range 1) * 
C 
      ns=NWN1 
      if(ns.eq.0)return 
      w2=WNRs(2) 
      w1=WNRs(1) 
      iter=0 
      sImax1=0.d0 
      sImax2=0.d0 
      nint=0 
c      write(*,*) 
c 
   10 iter=iter+1 
c      write(*,*) 
c      write(*,*)'iter=',iter 
      dw=(w2-w1)/ns 
      H=dw/RR 
      CALL INTEGS1(OM,W1,QX1,QZ1,VX1,WX1,WZ1) 
      nint=nint+1 
      IF(IOT.eq.1)THEN 
        WRITE(20,1100)W1,QX1(0),VX1(0),WX1(0),QZ1(0),WZ1(0) 
     *                  ,QX1(1),VX1(1),WX1(1),QZ1(1),WZ1(1) 
     *                  ,QX1(2),VX1(2),WX1(2),QZ1(2),WZ1(2) 
      END IF 
 1100 FORMAT(31E12.4) 
c 
      DO  100 I=1,ns 
c 
c     * 3 Points Newton-Cotes (Simpson) Quadrature * 
c     * 1-2-3 * 
c 
c        index=1
        W3=W1+dw*dfloat(I) 
        W2=W3-dw*0.5d0 
        CALL INTEGS1(OM,W2,QX2,QZ2,VX2,WX2,WZ2) 
        CALL INTEGS1(OM,W3,QX3,QZ3,VX3,WX3,WZ3) 
        nint=nint+2 
        sI11=cdabs((QZ1(2)+4.d0*QZ2(2)+QZ3(2)))*H/6.d0
        sI12=cdabs((VX1(2)+4.d0*VX2(2)+VX3(2)))*H/6.d0
        sInt1=sI11 
        sInt2=sI12 
        if(sI11.ge.sImax1)sImax1=sI11 
        if(sI12.ge.sImax2)sImax2=sI12 
        if(((sI11/sImax1).lt.0.001d0).and. 
     *                       ((sI12/sImax2).lt.0.001d0))then 
c          write(*,*)'i,index=',i,index 
c          write(*,*)'sI11,sI12',sI11,sI12 
c          write(*,*)'sImax1,sImax2',sImax1,sImax2 
c          write(*,*)'sI11/sImax1 < 0.001d !!!: sI11/sImax1=',sI11/sImax1 
c          write(*,*)'sI12/sImax2 < 0.001d !!!: sI12/sImax2=',sI12/sImax2 
          DO J=0,2 
            GQX(J)= GQX(J)+H*(QX1(J)+4.d0*QX2(J)+QX3(J))/6.d0
            GVX(J)= GVX(J)+H*(VX1(J)+4.d0*VX2(J)+VX3(J))/6.d0
            GWX(J)= GWX(J)+H*(WX1(J)+4.d0*WX2(J)+WX3(J))/6.d0
            GQZ(J)= GQZ(J)+H*(QZ1(J)+4.d0*QZ2(J)+QZ3(J))/6.d0
            GWZ(J)= GWZ(J)+H*(WZ1(J)+4.d0*WZ2(J)+WZ3(J))/6.d0
            QX1(J)= QX3(J) 
            VX1(J)= VX3(J) 
            WX1(J)= WX3(J) 
            QZ1(J)= QZ3(J) 
            WZ1(J)= WZ3(J) 
          end do 
          IF(IOT.eq.1)THEN 
            WRITE(20,1100)W2,QX2(0),VX2(0),WX2(0),QZ2(0),WZ2(0) 
     *                      ,QX2(1),VX2(1),WX2(1),QZ2(1),WZ2(1) 
     *                      ,QX2(2),VX2(2),WX2(2),QZ2(2),WZ2(2) 
            WRITE(20,1100)W3,QX3(0),VX3(0),WX3(0),QZ3(0),WZ3(0) 
     *                      ,QX3(1),VX3(1),WX3(1),QZ3(1),WZ3(1) 
     *                      ,QX3(2),VX3(2),WX3(2),QZ3(2),WZ3(2) 
          END IF 
          goto 100 
        end if 
c 
c     * 5 Points Newton-Cotes Quadrature * 
c     * 1-4-2-5-3 * 
c 
c        index=2
        W4=W3-dw*0.75d0 
        CALL INTEGS1(OM,W4,QX4,QZ4,VX4,WX4,WZ4) 
        W5=W3-dw*0.25d0 
        CALL INTEGS1(OM,W5,QX5,QZ5,VX5,WX5,WZ5) 
        nint=nint+2 
       aa=7.d0*QZ1(2)+32.d0*QZ4(2)+12.d0*QZ2(2)+32.d0*QZ5(2)+7.d0*QZ3(2)
        sI21=cdabs(aa)*H/90.d0
       aa=7.d0*VX1(2)+32.d0*VX4(2)+12.d0*VX2(2)+32.d0*VX5(2)+7.d0*VX3(2)
        sI22=cdabs(aa)*H/90.d0
        sInt1=sI21 
        sInt2=sI22 
        if(sI21.ge.sImax1)sImax1=sI21 
        if(sI22.ge.sImax2)sImax2=sI22 
        er11=dabs((sI11-sI21)/sI21) 
        er12=dabs((sI12-sI22)/sI22) 
        if((er11.lt.0.0001d0).and.(er12.lt.0.0001d0))then 
c          write(*,*)'i,index=',i,index 
c          write(*,*)'sI11,sI12',sI11,sI12 
c           write(*,*)'sI21,sI22',sI21,sI22 
c          write(*,*)'er11,er12',er11,er12 
          do J=0,2 
            aa= 7.d0*QX1(J)+32.d0*QX4(J)+12.d0*QX2(J)
            GQX(J)= GQX(J)+H*(aa+32.d0*QX5(J)+7.d0*QX3(J))/90.d0
            aa= 7.d0*VX1(J)+32.d0*VX4(J)+12.d0*VX2(J)
            GVX(J)= GVX(J)+H*(aa+32.d0*VX5(J)+7.d0*VX3(J))/90.d0
            aa= 7.d0*WX1(J)+32.d0*WX4(J)+12.d0*WX2(J)
            GWX(J)= GWX(J)+H*(aa+32.d0*WX5(J)+7.d0*WX3(J))/90.d0
            aa= 7.d0*QZ1(J)+32.d0*QZ4(J)+12.d0*QZ2(J)
            GQZ(J)= GQZ(J)+H*(aa+32.d0*QZ5(J)+7.d0*QZ3(J))/90.d0
            aa= 7.d0*WZ1(J)+32.d0*WZ4(J)+12.d0*WZ2(J)
            GWZ(J)= GWZ(J)+H*(aa+32.d0*WZ5(J)+7.d0*WZ3(J))/90.d0
            QX1(J)= QX3(J) 
            VX1(J)= VX3(J) 
            WX1(J)= WX3(J) 
            QZ1(J)= QZ3(J) 
            WZ1(J)= WZ3(J) 
          end do 
          IF(IOT.eq.1)THEN 
            WRITE(20,1100)W4,QX4(0),VX4(0),WX4(0),QZ4(0),WZ4(0) 
     *                     ,QX4(1),VX4(1),WX4(1),QZ4(1),WZ4(1) 
     *                      ,QX4(2),VX4(2),WX4(2),QZ4(2),WZ4(2) 
            WRITE(20,1100)W2,QX2(0),VX2(0),WX2(0),QZ2(0),WZ2(0) 
     *                            ,QX2(1),VX2(1),WX2(1),QZ2(1),WZ2(1) 
     *                            ,QX2(2),VX2(2),WX2(2),QZ2(2),WZ2(2) 
            WRITE(20,1100)W5,QX5(0),VX5(0),WX5(0),QZ5(0),WZ5(0) 
     *                            ,QX5(1),VX5(1),WX5(1),QZ5(1),WZ5(1) 
     *                            ,QX5(2),VX5(2),WX5(2),QZ5(2),WZ5(2) 
            WRITE(20,1100)W3,QX3(0),VX3(0),WX3(0),QZ3(0),WZ3(0) 
     *                            ,QX3(1),VX3(1),WX3(1),QZ3(1),WZ3(1) 
     *                            ,QX3(2),VX3(2),WX3(2),QZ3(2),WZ3(2) 
          END IF 
          goto 100 
        end if 
c 
c     * 9 Points Newton-Cotes Quadrature * 
c     * 1-6-4-7-2-8-5-9-3 * 
c 
c        index=3
        W6=W3-dw*0.875d0 
        CALL INTEGS1(OM,W6,QX6,QZ6,VX6,WX6,WZ6) 
        W7=W3-dw*0.625d0 
        CALL INTEGS1(OM,W7,QX7,QZ7,VX7,WX7,WZ7) 
        W8=W3-dw*0.375d0 
        CALL INTEGS1(OM,W8,QX8,QZ8,VX8,WX8,WZ8) 
        W9=W3-dw*0.125d0 
        CALL INTEGS1(OM,W9,QX9,QZ9,VX9,WX9,WZ9) 
        nint=nint+4
        aa=989.d0*QZ1(2)+5888.d0*QZ6(2)-928.d0*QZ4(2)+10496.d0*QZ7(2)
     *    -4540.d0*QZ2(2)+10496.d0*QZ8(2)-928.d0*QZ5(2)+5888.d0*QZ9(2)
     *    +989.d0*QZ3(2)
        sI31=cdabs(aa)*H/28350.d0
        aa=989.d0*VX1(2)+5888.d0*VX6(2)-928.d0*VX4(2)+10496.d0*VX7(2)
     *    -4540.d0*VX2(2)+10496.d0*VX8(2)-928.d0*VX5(2)+5888.d0*VX9(2)
     *    +989.d0*VX3(2)
        sI32=cdabs(aa)*H/28350.d0
        sInt1=sI31 
        sInt2=sI32 
        if(sI31.ge.sImax1)sImax1=sI31 
        if(sI32.ge.sImax2)sImax2=sI32 
        er21=dabs((sI21-sI31)/sI31) 
        er22=dabs((sI22-sI32)/sI32) 
        if((er21.lt.0.0001d0).and.(er22.lt.0.0001d0))then 
c          write(*,*)'i,index=',i,index 
c          write(*,*)'sI11,sI12',sI11,sI12 
c           write(*,*)'sI21,sI22',sI21,sI22 
c           write(*,*)'sI31,sI32',sI31,sI32 
c          write(*,*)'er21,er22',er21,er22 
          do J=0,2 
          aa= 989.d0*QX1(J)+5888.d0*QX6(J)-928.d0*QX4(J)+10496.d0*QX7(J)
            aa= aa-4540.d0*QX2(J)+10496.d0*QX8(J)-928.d0*QX5(J)
            GQX(J)= GQX(J)+H*(aa+5888.d0*QX9(J)+989.d0*QX3(J))/28350.d0
          aa= 989.d0*VX1(J)+5888.d0*VX6(J)-928.d0*VX4(J)+10496.d0*VX7(J)
            aa= aa-4540.d0*VX2(J)+10496.d0*VX8(J)-928.d0*VX5(J)
            GVX(J)= GVX(J)+H*(aa+5888.d0*VX9(J)+989.d0*VX3(J))/28350.d0
          aa= 989.d0*WX1(J)+5888.d0*WX6(J)-928.d0*WX4(J)+10496.d0*WX7(J)
            aa= aa-4540.d0*WX2(J)+10496.d0*WX8(J)-928.d0*WX5(J)
            GWX(J)= GWX(J)+H*(aa+5888.d0*WX9(J)+989.d0*WX3(J))/28350.d0
          aa= 989.d0*QZ1(J)+5888.d0*QZ6(J)-928.d0*QZ4(J)+10496.d0*QZ7(J)
            aa= aa-4540.d0*QZ2(J)+10496.d0*QZ8(J)-928.d0*QZ5(J)
            GQZ(J)= GQZ(J)+H*(aa+5888.d0*QZ9(J)+989.d0*QZ3(J))/28350.d0
          aa= 989.d0*WZ1(J)+5888.d0*WZ6(J)-928.d0*WZ4(J)+10496.d0*WZ7(J)
            aa= aa-4540.d0*WZ2(J)+10496.d0*WZ8(J)-928.d0*WZ5(J)
            GWZ(J)= GWZ(J)+H*(aa+5888.d0*WZ9(J)+989.d0*WZ3(J))/28350.d0
            QX1(J)= QX3(J) 
            VX1(J)= VX3(J) 
            WX1(J)= WX3(J) 
            QZ1(J)= QZ3(J) 
            WZ1(J)= WZ3(J) 
          end do 
          IF(IOT.eq.1)THEN 
            WRITE(20,1100)W6,QX6(0),VX6(0),WX6(0),QZ6(0),WZ6(0) 
     *                            ,QX6(1),VX6(1),WX6(1),QZ6(1),WZ6(1) 
     *                            ,QX6(2),VX6(2),WX6(2),QZ6(2),WZ6(2) 
            WRITE(20,1100)W4,QX4(0),VX4(0),WX4(0),QZ4(0),WZ4(0) 
     *                            ,QX4(1),VX4(1),WX4(1),QZ4(1),WZ4(1) 
     *                            ,QX4(2),VX4(2),WX4(2),QZ4(2),WZ4(2) 
            WRITE(20,1100)W7,QX7(0),VX7(0),WX7(0),QZ7(0),WZ7(0) 
     *                            ,QX7(1),VX7(1),WX7(1),QZ7(1),WZ7(1) 
     *                            ,QX7(2),VX7(2),WX7(2),QZ7(2),WZ7(2) 
            WRITE(20,1100)W2,QX2(0),VX2(0),WX2(0),QZ2(0),WZ2(0) 
     *                            ,QX2(1),VX2(1),WX2(1),QZ2(1),WZ2(1) 
     *                            ,QX2(2),VX2(2),WX2(2),QZ2(2),WZ2(2) 
            WRITE(20,1100)W8,QX8(0),VX8(0),WX8(0),QZ8(0),WZ8(0) 
     *                            ,QX8(1),VX8(1),WX8(1),QZ8(1),WZ8(1) 
     *                            ,QX8(2),VX8(2),WX8(2),QZ8(2),WZ8(2) 
            WRITE(20,1100)W5,QX5(0),VX5(0),WX5(0),QZ5(0),WZ5(0) 
     *                            ,QX5(1),VX5(1),WX5(1),QZ5(1),WZ5(1) 
     *                            ,QX5(2),VX5(2),WX5(2),QZ5(2),WZ5(2) 
            WRITE(20,1100)W9,QX9(0),VX9(0),WX9(0),QZ9(0),WZ9(0) 
     *                            ,QX9(1),VX9(1),WX9(1),QZ9(1),WZ9(1) 
     *                            ,QX9(2),VX9(2),WX9(2),QZ9(2),WZ9(2) 
            WRITE(20,1100)W3,QX3(0),VX3(0),WX3(0),QZ3(0),WZ3(0) 
     *                            ,QX3(1),VX3(1),WX3(1),QZ3(1),WZ3(1) 
     *                            ,QX3(2),VX3(2),WX3(2),QZ3(2),WZ3(2) 
          END IF 
          goto 100 
        end if 
c 
c     * 2 x 9 Points Newton-Cotes Quadrature * 
c     * 1-10-6-11-4-12-7-13-2 *  +  * 2-14-8-15-5-16-9-17-3 * 
c 
c        index=4
        W10=W3-dw*0.9375d0 
        CALL INTEGS1(OM,W10,QX10,QZ10,VX10,WX10,WZ10) 
        W11=W3-dw*0.8125d0 
        CALL INTEGS1(OM,W11,QX11,QZ11,VX11,WX11,WZ11) 
        W12=W3-dw*0.6875d0 
        CALL INTEGS1(OM,W12,QX12,QZ12,VX12,WX12,WZ12) 
        W13=W3-dw*0.5625d0 
        CALL INTEGS1(OM,W13,QX13,QZ13,VX13,WX13,WZ13) 
        W14=W3-dw*0.4375d0 
        CALL INTEGS1(OM,W14,QX14,QZ14,VX14,WX14,WZ14) 
        W15=W3-dw*0.3125d0 
        CALL INTEGS1(OM,W15,QX15,QZ15,VX15,WX15,WZ15) 
        W16=W3-dw*0.1875d0 
        CALL INTEGS1(OM,W16,QX16,QZ16,VX16,WX16,WZ16) 
        W17=W3-dw*0.0625d0 
        CALL INTEGS1(OM,W17,QX17,QZ17,VX17,WX17,WZ17) 
        nint=nint+8 
        aa=   989.d0* QZ1(2)+5888.d0*QZ10(2)-  928.d0* QZ6(2)
     *           +10496.d0*QZ11(2)-4540.d0* QZ4(2)+10496.d0*QZ12(2)
     *       -928.d0* QZ7(2)+5888.d0*QZ13(2)+  989.d0* QZ2(2)
        aa=aa+989.d0* QZ2(2)+5888.d0*QZ14(2)-  928.d0* QZ8(2)
     *     +10496.d0*QZ15(2)-4540.d0* QZ5(2)+10496.d0*QZ16(2)
     *             -928.d0* QZ9(2)+5888.d0*QZ17(2)+  989.d0* QZ3(2)
        sI41=cdabs(aa)*H/56700.d0
        aa=   989.d0* VX1(2)+5888.d0*VX10(2)-  928.d0* VX6(2)
     *           +10496.d0*VX11(2)-4540.d0* VX4(2)+10496.d0*VX12(2)
     *       -928.d0* VX7(2)+5888.d0*VX13(2)+  989.d0* VX2(2)
        aa=aa+989.d0* VX2(2)+5888.d0*VX14(2)-  928.d0* VX8(2)
     *     +10496.d0*VX15(2)-4540.d0* VX5(2)+10496.d0*VX16(2)
     *             -928.d0* VX9(2)+5888.d0*VX17(2)+  989.d0* VX3(2)
        sI42=cdabs(aa)*H/56700.d0
        sInt1=sI41 
        sInt2=sI42 
        if(sI41.ge.sImax1)sImax1=sI41 
        if(sI42.ge.sImax2)sImax2=sI42 
        er31=dabs((sI31-sI41)/sI41) 
        er32=dabs((sI32-sI42)/sI42) 
c 
c        write(*,*)'i,index=',i,index 
c        write(*,*)'sI11,sI12',sI11,sI12 
c         write(*,*)'sI21,sI22',sI21,sI22 
c         write(*,*)'sI31,sI32',sI31,sI32 
c         write(*,*)'sI41,sI42',sI41,sI42 
c        write(*,*)'er31,er32',er31,er32 
        if((er31.gt.0.0001d0).or.(er32.gt.0.0001d0))then 
          if(((sI41/sImax1).gt.0.0001d0). 
     *                      or.((sI42/sImax2).lt.0.0001d0))then 
c            write(*,*)'sI41/sImax1,sI42/sImax2=',sI41/sImax1,sI42/sImax2 
c            write(*,*)'Increase Number of ns for Static Integ 1 !!!!!' 
          end if 
        end if 
c 
        do J=0,2 
            aa=   989.d0* QX1(J)+5888.d0*QX10(J)-  928.d0* QX6(J)
     *               +10496.d0*QX11(J)-4540.d0* QX4(J)+10496.d0*QX12(J)
     *           -928.d0* QX7(J)+5888.d0*QX13(J)+  989.d0* QX2(J)
            aa=aa+989.d0* QX2(J)+5888.d0*QX14(J)-  928.d0* QX8(J)
     *         +10496.d0*QX15(J)-4540.d0* QX5(J)+10496.d0*QX16(J)
     *                 -928.d0* QX9(J)+5888.d0*QX17(J)+  989.d0* QX3(J)
            GQX(J)= GQX(J)+H*aa/56700.d0
            aa=   989.d0* VX1(J)+5888.d0*VX10(J)-  928.d0* VX6(J)
     *               +10496.d0*VX11(J)-4540.d0* VX4(J)+10496.d0*VX12(J)
     *           -928.d0* VX7(J)+5888.d0*VX13(J)+  989.d0* VX2(J)
            aa=aa+989.d0* VX2(J)+5888.d0*VX14(J)-  928.d0* VX8(J)
     *         +10496.d0*VX15(J)-4540.d0* VX5(J)+10496.d0*VX16(J)
     *                 -928.d0* VX9(J)+5888.d0*VX17(J)+  989.d0* VX3(J)
            GVX(J)= GVX(J)+H*aa/56700.d0
            aa=   989.d0* WX1(J)+5888.d0*WX10(J)-  928.d0* WX6(J)
     *               +10496.d0*WX11(J)-4540.d0* WX4(J)+10496.d0*WX12(J)
     *           -928.d0* WX7(J)+5888.d0*WX13(J)+  989.d0* WX2(J)
            aa=aa+989.d0* WX2(J)+5888.d0*WX14(J)-  928.d0* WX8(J)
     *         +10496.d0*WX15(J)-4540.d0* WX5(J)+10496.d0*WX16(J)
     *                 -928.d0* WX9(J)+5888.d0*WX17(J)+  989.d0* WX3(J)
            GWX(J)= GWX(J)+H*aa/56700.d0
            aa=   989.d0* QZ1(J)+5888.d0*QZ10(J)-  928.d0* QZ6(J)
     *               +10496.d0*QZ11(J)-4540.d0* QZ4(J)+10496.d0*QZ12(J)
     *           -928.d0* QZ7(J)+5888.d0*QZ13(J)+  989.d0* QZ2(J)
            aa=aa+989.d0* QZ2(J)+5888.d0*QZ14(J)-  928.d0* QZ8(J)
     *         +10496.d0*QZ15(J)-4540.d0* QZ5(J)+10496.d0*QZ16(J)
     *                 -928.d0* QZ9(J)+5888.d0*QZ17(J)+  989.d0* QZ3(J)
            GQZ(J)= GQZ(J)+H*aa/56700.d0
            aa=   989.d0* WZ1(J)+5888.d0*WZ10(J)-  928.d0* WZ6(J)
     *               +10496.d0*WZ11(J)-4540.d0* WZ4(J)+10496.d0*WZ12(J)
     *           -928.d0* WZ7(J)+5888.d0*WZ13(J)+  989.d0* WZ2(J)
            aa=aa+989.d0* WZ2(J)+5888.d0*WZ14(J)-  928.d0* WZ8(J)
     *         +10496.d0*WZ15(J)-4540.d0* WZ5(J)+10496.d0*WZ16(J)
     *                 -928.d0* WZ9(J)+5888.d0*WZ17(J)+  989.d0* WZ3(J)
            GWZ(J)= GWZ(J)+H*aa/56700.d0
            QX1(J)= QX3(J) 
            VX1(J)= VX3(J) 
            WX1(J)= WX3(J) 
            QZ1(J)= QZ3(J) 
            WZ1(J)= WZ3(J) 
        end do 
          IF(IOT.eq.1)THEN 
            WRITE(20,1100)W6,QX6(0),VX6(0),WX6(0),QZ6(0),WZ6(0) 
     *                            ,QX6(1),VX6(1),WX6(1),QZ6(1),WZ6(1) 
     *                            ,QX6(2),VX6(2),WX6(2),QZ6(2),WZ6(2) 
            WRITE(20,1100)W4,QX4(0),VX4(0),WX4(0),QZ4(0),WZ4(0) 
     *                            ,QX4(1),VX4(1),WX4(1),QZ4(1),WZ4(1) 
     *                            ,QX4(2),VX4(2),WX4(2),QZ4(2),WZ4(2) 
            WRITE(20,1100)W7,QX7(0),VX7(0),WX7(0),QZ7(0),WZ7(0) 
     *                            ,QX7(1),VX7(1),WX7(1),QZ7(1),WZ7(1) 
     *                            ,QX7(2),VX7(2),WX7(2),QZ7(2),WZ7(2) 
            WRITE(20,1100)W2,QX2(0),VX2(0),WX2(0),QZ2(0),WZ2(0) 
     *                            ,QX2(1),VX2(1),WX2(1),QZ2(1),WZ2(1) 
     *                            ,QX2(2),VX2(2),WX2(2),QZ2(2),WZ2(2) 
            WRITE(20,1100)W8,QX8(0),VX8(0),WX8(0),QZ8(0),WZ8(0) 
     *                            ,QX8(1),VX8(1),WX8(1),QZ8(1),WZ8(1) 
     *                            ,QX8(2),VX8(2),WX8(2),QZ8(2),WZ8(2) 
            WRITE(20,1100)W5,QX5(0),VX5(0),WX5(0),QZ5(0),WZ5(0) 
     *                            ,QX5(1),VX5(1),WX5(1),QZ5(1),WZ5(1) 
     *                            ,QX5(2),VX5(2),WX5(2),QZ5(2),WZ5(2) 
            WRITE(20,1100)W9,QX9(0),VX9(0),WX9(0),QZ9(0),WZ9(0) 
     *                            ,QX9(1),VX9(1),WX9(1),QZ9(1),WZ9(1) 
     *                            ,QX9(2),VX9(2),WX9(2),QZ9(2),WZ9(2) 
            WRITE(20,1100)W3,QX3(0),VX3(0),WX3(0),QZ3(0),WZ3(0) 
     *                            ,QX3(1),VX3(1),WX3(1),QZ3(1),WZ3(1) 
     *                            ,QX3(2),VX3(2),WX3(2),QZ3(2),WZ3(2) 
          END IF 
 
  100 CONTINUE 
c 
c      write(*,*) 
c      write(*,*)'sInt1       ,sInt2        ',sInt1,sInt2 
c      write(*,*)'sImax1      ,sImax2       ',sImax1,sImax2 
c      write(*,*)'sInt1/sImax1,sInt2/sImax2=',sInt1/sImax1,sInt2/sImax2 
      if(((sInt1/sImax1).lt.0.00001d0) 
     *                  .and.((sInt2/sImax2).lt.0.00001d0))then 
c        write(*,*)'sInt1/sImax1 & sInt2/sImax2 < 0.00001d !!!' 
c        write(*,*)'NWN2 is set to be 0 !!!' 
        NWN2=0 
        goto 20 
      end if 
c 
      if(((sInt1/sImax1).lt.0.5d0).and.((sInt2/sImax2).lt.0.5d0))then 
        if(iter.gt.20)then 
          write(10,*)'iter > 20 !!' 
          write(10,*)'SDEP,ODEP,LS,LO',SDEP,ODEP,LS,LO 
          write(10,*)'OM,RR',OM,RR 
          goto 20 
        end if 
c        write(*,*)'sInt1/sImax1 & sInt2/sImax2 < 0.5d !!!'  
c        write(*,*)  
        w1=WNRs(2)*iter 
        w2=w1+WNRs(2) 
        if(ns.ge.2)then 
          ns=ns/2 
          sImax1=sImax1*2.d0 
          sImax2=sImax2*2.d0 
        end if 
        goto 10 
      end if 
c 
c   20      write(*,*) 
c      write(*,*)'Static Integration 1:' 
c      write(*,*)'Number of Integration Range =',iter 
c   20 write(*,*)'Number of Integ. Points for Static Range 1=',nint 
c   20 write(10,*)'Itr. & Intg. Pnt. Num. for Static Range 1=',iter,nint
   20 NWT1=NWT1+nint
c 
      return 
      end 
C 
C 
C *** THE INTEGRANDS OF Q, V, AND W AND THEIR DERIVATIVES for Static Range 1 *** 
C 
      SUBROUTINE INTEGS1(OM,RK,QX,QZ,VX,WX,WZ) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 QX(0:2),QZ(0:2),VX(0:2),WX(0:2),WZ(0:2),OM 
     *   ,VLX(2),URX(2,2),URZ(2,2),VLXZ,URXZ(2),URZZ(2),SM,RAM,WN 
      DIMENSION BJ0(0:1),BJ1(0:1),BJK(0:1),BJD(0:1) 
      COMMON /FCQVW/SM,RAM,RR
C 
c   * the displacement-stress vectors * 
c 
      WNr=RK/RR
      WN=dcmplx(WNr,0.d0)
      CALL RTSHc(OM,WN,VLX)
      CALL RTPSVc(OM,WN,URX,URZ) 
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.d0*SM)
      URZZ(2)=(URZ(2,2)-WN*RAM*URZ(1,1))/(RAM+2.d0*SM)
C 
c   * the Bessel functions * 
c 
      call bj01(RK,BJ0(0),BJ1(0)) 
      IF(RK.EQ.0.d0)THEN
        BJK(0)=0.5d0
      ELSE 
        BJK(0)=BJ1(0)/RK 
      END IF 
      BJD(0)=BJ0(0)-BJK(0) 
C 
      BJ0(1)=-BJ1(0)*WNr
      BJ1(1)= BJD(0)*WNr
      IF(RK.EQ.0.d0)THEN
        BJK(1)=0.d0
      ELSE 
        BJK(1)=(BJ1(1)-BJ1(0)/RR)/RK 
      END IF 
      BJD(1)= BJ0(1)-BJK(1) 
C 
c   * the integrands * 
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) 
      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) 
      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 
C 
C *** THE COMPUTATION OF Q, V, AND W AND THEIR DERIVATIVES  
C     USING Newton-Cotes Quadrature (for Static Range 2: ka - kb & kc on imag k axis)*** 
C 
      SUBROUTINE QVWRZS2(OM,GQX,GQZ,GVX,GWX,GWZ) 
C      
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 GQX(0:2),GQZ(0:2),GVX(0:2),GWX(0:2),GWZ(0:2) 
     *          ,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) 
     *          ,QX3(0:2),QZ3(0:2),VX3(0:2),WX3(0:2),WZ3(0:2) 
     *          ,QX4(0:2),QZ4(0:2),VX4(0:2),WX4(0:2),WZ4(0:2) 
     *          ,QX5(0:2),QZ5(0:2),VX5(0:2),WX5(0:2),WZ5(0:2) 
     *          ,QX6(0:2),QZ6(0:2),VX6(0:2),WX6(0:2),WZ6(0:2) 
     *          ,QX7(0:2),QZ7(0:2),VX7(0:2),WX7(0:2),WZ7(0:2) 
     *          ,QX8(0:2),QZ8(0:2),VX8(0:2),WX8(0:2),WZ8(0:2) 
     *          ,QX9(0:2),QZ9(0:2),VX9(0:2),WX9(0:2),WZ9(0:2) 
     *          ,QX10(0:2),QZ10(0:2),VX10(0:2),WX10(0:2),WZ10(0:2) 
     *          ,QX11(0:2),QZ11(0:2),VX11(0:2),WX11(0:2),WZ11(0:2) 
     *          ,QX12(0:2),QZ12(0:2),VX12(0:2),WX12(0:2),WZ12(0:2) 
     *          ,QX13(0:2),QZ13(0:2),VX13(0:2),WX13(0:2),WZ13(0:2) 
     *          ,QX14(0:2),QZ14(0:2),VX14(0:2),WX14(0:2),WZ14(0:2) 
     *          ,QX15(0:2),QZ15(0:2),VX15(0:2),WX15(0:2),WZ15(0:2) 
     *          ,QX16(0:2),QZ16(0:2),VX16(0:2),WX16(0:2),WZ16(0:2) 
     *          ,QX17(0:2),QZ17(0:2),VX17(0:2),WX17(0:2),WZ17(0:2) 
     *          ,OM,SM,RAM,aa 
      COMMON /WVNUMs/WNRs(3),NWN1o,NWN2o,NWN1,NWN2,NWT1,NWT2 
     *       /OTST/IOT,IST /FCQVW/SM,RAM,RR 
C 
C   * Simpson's INTEGATION FOMULA (for Static Range 2) * 
C 
      ns=NWN2 
      if(ns.eq.0)return 
c 
      WR=WNRs(2) 
      w2=WNRs(3) 
      w1=0.d0 
      iter=0 
      sImax1=0.d0 
      sImax2=0.d0 
      nint=0 
c      write(*,*) 
c 
   10 iter=iter+1 
c      write(*,*) 
c      write(*,*)'iter=',iter 
      dw=(w2-w1)/ns 
      H=dw/RR 
      CALL INTEGS2(OM,WR,W1,QX1,QZ1,VX1,WX1,WZ1) 
      nint=nint+1 
      IF(IOT.eq.1)THEN 
        WRITE(21,1100)W1,QX1(0),VX1(0),WX1(0),QZ1(0),WZ1(0) 
     *                        ,QX1(1),VX1(1),WX1(1),QZ1(1),WZ1(1) 
     *                        ,QX1(2),VX1(2),WX1(2),QZ1(2),WZ1(2) 
      END IF 
 1100 FORMAT(31E12.4) 
c 
      DO  100 I=1,ns 
c 
c     * 3 Points Newton-Cotes (Simpson) Quadrature * 
c     * 1-2-3 * 
c 
c        index=1
        W3=W1+dw*dfloat(I) 
        W2=W3-dw*0.5d0 
        CALL INTEGS2(OM,WR,W2,QX2,QZ2,VX2,WX2,WZ2) 
        CALL INTEGS2(OM,WR,W3,QX3,QZ3,VX3,WX3,WZ3) 
        nint=nint+2 
        sI11=cdabs((QZ1(2)+4.d0*QZ2(2)+QZ3(2)))*H/6.d0
        sI12=cdabs((VX1(2)+4.d0*VX2(2)+VX3(2)))*H/6.d0
        sInt1=sI11 
        sInt2=sI12 
        if(sI11.ge.sImax1)sImax1=sI11 
        if(sI12.ge.sImax2)sImax2=sI12 
        if(((sI11/sImax1).lt.0.001d0).and. 
     *                       ((sI12/sImax2).lt.0.001d0))then 
c          write(*,*)'i,index=',i,index 
c          write(*,*)'sI11,sI12',sI11,sI12 
c          write(*,*)'sImax1,sImax2',sImax1,sImax2 
c          write(*,*)'sI11/sImax1 < 0.001d !!!: sI11/sImax1=',sI11/sImax1 
c          write(*,*)'sI12/sImax2 < 0.001d !!!: sI12/sImax2=',sI12/sImax2 
          DO J=0,2 
            GQX(J)= GQX(J)+H*(QX1(J)+4.d0*QX2(J)+QX3(J))/6.d0
            GVX(J)= GVX(J)+H*(VX1(J)+4.d0*VX2(J)+VX3(J))/6.d0
            GWX(J)= GWX(J)+H*(WX1(J)+4.d0*WX2(J)+WX3(J))/6.d0
            GQZ(J)= GQZ(J)+H*(QZ1(J)+4.d0*QZ2(J)+QZ3(J))/6.d0
            GWZ(J)= GWZ(J)+H*(WZ1(J)+4.d0*WZ2(J)+WZ3(J))/6.d0
            QX1(J)= QX3(J) 
            VX1(J)= VX3(J) 
            WX1(J)= WX3(J) 
            QZ1(J)= QZ3(J) 
            WZ1(J)= WZ3(J) 
          end do 
          IF(IOT.eq.1)THEN 
            WRITE(21,1100)W2,QX2(0),VX2(0),WX2(0),QZ2(0),WZ2(0) 
     *                            ,QX2(1),VX2(1),WX2(1),QZ2(1),WZ2(1) 
     *                            ,QX2(2),VX2(2),WX2(2),QZ2(2),WZ2(2) 
            WRITE(21,1100)W3,QX3(0),VX3(0),WX3(0),QZ3(0),WZ3(0) 
     *                            ,QX3(1),VX3(1),WX3(1),QZ3(1),WZ3(1) 
     *                            ,QX3(2),VX3(2),WX3(2),QZ3(2),WZ3(2) 
          END IF 
          goto 100 
        end if 
c 
c     * 5 Points Newton-Cotes Quadrature * 
c     * 1-4-2-5-3 * 
c 
c        index=2
        W4=W3-dw*0.75d0 
        CALL INTEGS2(OM,WR,W4,QX4,QZ4,VX4,WX4,WZ4) 
        W5=W3-dw*0.25d0 
        CALL INTEGS2(OM,WR,W5,QX5,QZ5,VX5,WX5,WZ5) 
        nint=nint+2 
       aa=7.d0*QZ1(2)+32.d0*QZ4(2)+12.d0*QZ2(2)+32.d0*QZ5(2)+7.d0*QZ3(2)
        sI21=cdabs(aa)*H/90.d0
       aa=7.d0*VX1(2)+32.d0*VX4(2)+12.d0*VX2(2)+32.d0*VX5(2)+7.d0*VX3(2)
        sI22=cdabs(aa)*H/90.d0
        sInt1=sI21 
        sInt2=sI22 
        if(sI21.ge.sImax1)sImax1=sI21 
        if(sI22.ge.sImax2)sImax2=sI22 
        er11=dabs((sI11-sI21)/sI21) 
        er12=dabs((sI12-sI22)/sI22) 
        if((er11.lt.0.0001d0).and.(er12.lt.0.0001d0))then 
c          write(*,*)'i,index=',i,index 
c          write(*,*)'sI11,sI12',sI11,sI12 
c          write(*,*)'sI21,sI22',sI21,sI22 
c          write(*,*)'er11,er12',er11,er12 
          do J=0,2 
            aa= 7.d0*QX1(J)+32.d0*QX4(J)+12.d0*QX2(J)
            GQX(J)= GQX(J)+H*(aa+32.d0*QX5(J)+7.d0*QX3(J))/90.d0
            aa= 7.d0*VX1(J)+32.d0*VX4(J)+12.d0*VX2(J)
            GVX(J)= GVX(J)+H*(aa+32.d0*VX5(J)+7.d0*VX3(J))/90.d0
            aa= 7.d0*WX1(J)+32.d0*WX4(J)+12.d0*WX2(J)
            GWX(J)= GWX(J)+H*(aa+32.d0*WX5(J)+7.d0*WX3(J))/90.d0
            aa= 7.d0*QZ1(J)+32.d0*QZ4(J)+12.d0*QZ2(J)
            GQZ(J)= GQZ(J)+H*(aa+32.d0*QZ5(J)+7.d0*QZ3(J))/90.d0
            aa= 7.d0*WZ1(J)+32.d0*WZ4(J)+12.d0*WZ2(J)
            GWZ(J)= GWZ(J)+H*(aa+32.d0*WZ5(J)+7.d0*WZ3(J))/90.d0
            QX1(J)= QX3(J) 
            VX1(J)= VX3(J) 
            WX1(J)= WX3(J) 
            QZ1(J)= QZ3(J) 
            WZ1(J)= WZ3(J) 
          end do 
          IF(IOT.eq.1)THEN 
            WRITE(21,1100)W4,QX4(0),VX4(0),WX4(0),QZ4(0),WZ4(0) 
     *                            ,QX4(1),VX4(1),WX4(1),QZ4(1),WZ4(1) 
     *                            ,QX4(2),VX4(2),WX4(2),QZ4(2),WZ4(2) 
            WRITE(21,1100)W2,QX2(0),VX2(0),WX2(0),QZ2(0),WZ2(0) 
     *                            ,QX2(1),VX2(1),WX2(1),QZ2(1),WZ2(1) 
     *                            ,QX2(2),VX2(2),WX2(2),QZ2(2),WZ2(2) 
            WRITE(21,1100)W5,QX5(0),VX5(0),WX5(0),QZ5(0),WZ5(0) 
     *                            ,QX5(1),VX5(1),WX5(1),QZ5(1),WZ5(1) 
     *                            ,QX5(2),VX5(2),WX5(2),QZ5(2),WZ5(2) 
            WRITE(21,1100)W3,QX3(0),VX3(0),WX3(0),QZ3(0),WZ3(0) 
     *                            ,QX3(1),VX3(1),WX3(1),QZ3(1),WZ3(1) 
     *                            ,QX3(2),VX3(2),WX3(2),QZ3(2),WZ3(2) 
          END IF 
          goto 100 
        end if 
c 
c     * 9 Points Simpson * 
c     * 1-6-4-7-2-8-5-9-3 * 
c 
c        index=3
        W6=W3-dw*0.875d0 
        CALL INTEGS2(OM,WR,W6,QX6,QZ6,VX6,WX6,WZ6) 
        W7=W3-dw*0.625d0 
        CALL INTEGS2(OM,WR,W7,QX7,QZ7,VX7,WX7,WZ7) 
        W8=W3-dw*0.375d0 
        CALL INTEGS2(OM,WR,W8,QX8,QZ8,VX8,WX8,WZ8) 
        W9=W3-dw*0.125d0 
        CALL INTEGS2(OM,WR,W9,QX9,QZ9,VX9,WX9,WZ9) 
        nint=nint+4 
        aa=989.d0*QZ1(2)+5888.d0*QZ6(2)-928.d0*QZ4(2)+10496.d0*QZ7(2)
     *    -4540.d0*QZ2(2)+10496.d0*QZ8(2)-928.d0*QZ5(2)+5888.d0*QZ9(2)
     *    +989.d0*QZ3(2)
        sI31=cdabs(aa)*H/28350.d0
        aa=989.d0*VX1(2)+5888.d0*VX6(2)-928.d0*VX4(2)+10496.d0*VX7(2)
     *    -4540.d0*VX2(2)+10496.d0*VX8(2)-928.d0*VX5(2)+5888.d0*VX9(2)
     *    +989.d0*VX3(2)
        sI32=cdabs(aa)*H/28350.d0
        sInt1=sI31 
        sInt2=sI32 
        if(sI31.ge.sImax1)sImax1=sI31 
        if(sI32.ge.sImax2)sImax2=sI32 
        er21=dabs((sI21-sI31)/sI31) 
        er22=dabs((sI22-sI32)/sI32) 
        if((er21.lt.0.0001d0).and.(er22.lt.0.0001d0))then 
c          write(*,*)'i,index=',i,index 
c          write(*,*)'sI11,sI12',sI11,sI12 
c           write(*,*)'sI21,sI22',sI21,sI22 
c           write(*,*)'sI31,sI32',sI31,sI32 
c          write(*,*)'er21,er22',er21,er22 
          do J=0,2 
          aa= 989.d0*QX1(J)+5888.d0*QX6(J)-928.d0*QX4(J)+10496.d0*QX7(J)
            aa= aa-4540.d0*QX2(J)+10496.d0*QX8(J)-928.d0*QX5(J)
            GQX(J)= GQX(J)+H*(aa+5888.d0*QX9(J)+989.d0*QX3(J))/28350.d0
          aa= 989.d0*VX1(J)+5888.d0*VX6(J)-928.d0*VX4(J)+10496.d0*VX7(J)
            aa= aa-4540.d0*VX2(J)+10496.d0*VX8(J)-928.d0*VX5(J)
            GVX(J)= GVX(J)+H*(aa+5888.d0*VX9(J)+989.d0*VX3(J))/28350.d0
          aa= 989.d0*WX1(J)+5888.d0*WX6(J)-928.d0*WX4(J)+10496.d0*WX7(J)
            aa= aa-4540.d0*WX2(J)+10496.d0*WX8(J)-928.d0*WX5(J)
            GWX(J)= GWX(J)+H*(aa+5888.d0*WX9(J)+989.d0*WX3(J))/28350.d0
          aa= 989.d0*QZ1(J)+5888.d0*QZ6(J)-928.d0*QZ4(J)+10496.d0*QZ7(J)
            aa= aa-4540.d0*QZ2(J)+10496.d0*QZ8(J)-928.d0*QZ5(J)
            GQZ(J)= GQZ(J)+H*(aa+5888.d0*QZ9(J)+989.d0*QZ3(J))/28350.d0
          aa= 989.d0*WZ1(J)+5888.d0*WZ6(J)-928.d0*WZ4(J)+10496.d0*WZ7(J)
            aa= aa-4540.d0*WZ2(J)+10496.d0*WZ8(J)-928.d0*WZ5(J)
            GWZ(J)= GWZ(J)+H*(aa+5888.d0*WZ9(J)+989.d0*WZ3(J))/28350.d0
            QX1(J)= QX3(J) 
            VX1(J)= VX3(J) 
            WX1(J)= WX3(J) 
            QZ1(J)= QZ3(J) 
            WZ1(J)= WZ3(J) 
          end do 
          IF(IOT.eq.1)THEN 
            WRITE(21,1100)W6,QX6(0),VX6(0),WX6(0),QZ6(0),WZ6(0) 
     *                            ,QX6(1),VX6(1),WX6(1),QZ6(1),WZ6(1) 
     *                            ,QX6(2),VX6(2),WX6(2),QZ6(2),WZ6(2) 
            WRITE(21,1100)W4,QX4(0),VX4(0),WX4(0),QZ4(0),WZ4(0) 
     *                            ,QX4(1),VX4(1),WX4(1),QZ4(1),WZ4(1) 
     *                            ,QX4(2),VX4(2),WX4(2),QZ4(2),WZ4(2) 
            WRITE(21,1100)W7,QX7(0),VX7(0),WX7(0),QZ7(0),WZ7(0) 
     *                            ,QX7(1),VX7(1),WX7(1),QZ7(1),WZ7(1) 
     *                            ,QX7(2),VX7(2),WX7(2),QZ7(2),WZ7(2) 
            WRITE(21,1100)W2,QX2(0),VX2(0),WX2(0),QZ2(0),WZ2(0) 
     *                            ,QX2(1),VX2(1),WX2(1),QZ2(1),WZ2(1) 
     *                            ,QX2(2),VX2(2),WX2(2),QZ2(2),WZ2(2) 
            WRITE(21,1100)W8,QX8(0),VX8(0),WX8(0),QZ8(0),WZ8(0) 
     *                            ,QX8(1),VX8(1),WX8(1),QZ8(1),WZ8(1) 
     *                            ,QX8(2),VX8(2),WX8(2),QZ8(2),WZ8(2) 
            WRITE(21,1100)W5,QX5(0),VX5(0),WX5(0),QZ5(0),WZ5(0) 
     *                            ,QX5(1),VX5(1),WX5(1),QZ5(1),WZ5(1) 
     *                            ,QX5(2),VX5(2),WX5(2),QZ5(2),WZ5(2) 
            WRITE(21,1100)W9,QX9(0),VX9(0),WX9(0),QZ9(0),WZ9(0) 
     *                            ,QX9(1),VX9(1),WX9(1),QZ9(1),WZ9(1) 
     *                            ,QX9(2),VX9(2),WX9(2),QZ9(2),WZ9(2) 
            WRITE(21,1100)W3,QX3(0),VX3(0),WX3(0),QZ3(0),WZ3(0) 
     *                            ,QX3(1),VX3(1),WX3(1),QZ3(1),WZ3(1) 
     *                            ,QX3(2),VX3(2),WX3(2),QZ3(2),WZ3(2) 
          END IF 
          goto 100 
        end if 
c 
c     * 2 x 9 Points Newton-Cotes Quadrature * 
c     * 1-10-6-11-4-12-7-13-2 *  +  * 2-14-8-15-5-16-9-17-3 * 
c 
c        index=4
        W10=W3-dw*0.9375d0 
        CALL INTEGS2(OM,WR,W10,QX10,QZ10,VX10,WX10,WZ10) 
        W11=W3-dw*0.8125d0 
        CALL INTEGS2(OM,WR,W11,QX11,QZ11,VX11,WX11,WZ11) 
        W12=W3-dw*0.6875d0 
        CALL INTEGS2(OM,WR,W12,QX12,QZ12,VX12,WX12,WZ12) 
        W13=W3-dw*0.5625d0 
        CALL INTEGS2(OM,WR,W13,QX13,QZ13,VX13,WX13,WZ13) 
        W14=W3-dw*0.4375d0 
        CALL INTEGS2(OM,WR,W14,QX14,QZ14,VX14,WX14,WZ14) 
        W15=W3-dw*0.3125d0 
        CALL INTEGS2(OM,WR,W15,QX15,QZ15,VX15,WX15,WZ15) 
        W16=W3-dw*0.1875d0 
        CALL INTEGS2(OM,WR,W16,QX16,QZ16,VX16,WX16,WZ16) 
        W17=W3-dw*0.0625d0 
        CALL INTEGS2(OM,WR,W17,QX17,QZ17,VX17,WX17,WZ17) 
        nint=nint+8 
        aa=   989.d0* QZ1(2)+5888.d0*QZ10(2)-  928.d0* QZ6(2)
     *           +10496.d0*QZ11(2)-4540.d0* QZ4(2)+10496.d0*QZ12(2)
     *       -928.d0* QZ7(2)+5888.d0*QZ13(2)+  989.d0* QZ2(2)
        aa=aa+989.d0* QZ2(2)+5888.d0*QZ14(2)-  928.d0* QZ8(2)
     *     +10496.d0*QZ15(2)-4540.d0* QZ5(2)+10496.d0*QZ16(2)
     *             -928.d0* QZ9(2)+5888.d0*QZ17(2)+  989.d0* QZ3(2)
        sI41=cdabs(aa)*H/56700.d0
        aa=   989.d0* VX1(2)+5888.d0*VX10(2)-  928.d0* VX6(2)
     *           +10496.d0*VX11(2)-4540.d0* VX4(2)+10496.d0*VX12(2)
     *       -928.d0* VX7(2)+5888.d0*VX13(2)+  989.d0* VX2(2)
        aa=aa+989.d0* VX2(2)+5888.d0*VX14(2)-  928.d0* VX8(2)
     *     +10496.d0*VX15(2)-4540.d0* VX5(2)+10496.d0*VX16(2)
     *             -928.d0* VX9(2)+5888.d0*VX17(2)+  989.d0* VX3(2)
        sI42=cdabs(aa)*H/56700.d0
        sInt1=sI41 
        sInt2=sI42 
        if(sI41.ge.sImax1)sImax1=sI41 
        if(sI42.ge.sImax2)sImax2=sI42 
        er31=dabs((sI31-sI41)/sI41) 
        er32=dabs((sI32-sI42)/sI42) 
c 
c        write(*,*)'i,index=',i,index 
c        write(*,*)'sI11,sI12',sI11,sI12 
c         write(*,*)'sI21,sI22',sI21,sI22 
c         write(*,*)'sI31,sI32',sI31,sI32 
c         write(*,*)'sI41,sI42',sI41,sI42 
c        write(*,*)'er31,er32',er31,er32 
        if((er31.gt.0.0001d0).or.(er32.gt.0.0001d0))then 
          if(((sI41/sImax1).gt.0.0001d0). 
     *                      or.((sI42/sImax2).lt.0.0001d0))then 
c            write(*,*)'sI41/sImax1,sI42/sImax2=',sI41/sImax1,sI42/sImax2 
c            write(*,*)'Increase Number of ns for Static Integ 2 !!!!!' 
          end if 
        end if 
c 
        do J=0,2 
            aa=   989.d0* QX1(J)+5888.d0*QX10(J)-  928.d0* QX6(J)
     *               +10496.d0*QX11(J)-4540.d0* QX4(J)+10496.d0*QX12(J)
     *           -928.d0* QX7(J)+5888.d0*QX13(J)+  989.d0* QX2(J)
            aa=aa+989.d0* QX2(J)+5888.d0*QX14(J)-  928.d0* QX8(J)
     *         +10496.d0*QX15(J)-4540.d0* QX5(J)+10496.d0*QX16(J)
     *                 -928.d0* QX9(J)+5888.d0*QX17(J)+  989.d0* QX3(J)
            GQX(J)= GQX(J)+H*aa/56700.d0
            aa=   989.d0* VX1(J)+5888.d0*VX10(J)-  928.d0* VX6(J)
     *               +10496.d0*VX11(J)-4540.d0* VX4(J)+10496.d0*VX12(J)
     *           -928.d0* VX7(J)+5888.d0*VX13(J)+  989.d0* VX2(J)
            aa=aa+989.d0* VX2(J)+5888.d0*VX14(J)-  928.d0* VX8(J)
     *         +10496.d0*VX15(J)-4540.d0* VX5(J)+10496.d0*VX16(J)
     *                 -928.d0* VX9(J)+5888.d0*VX17(J)+  989.d0* VX3(J)
            GVX(J)= GVX(J)+H*aa/56700.d0
            aa=   989.d0* WX1(J)+5888.d0*WX10(J)-  928.d0* WX6(J)
     *               +10496.d0*WX11(J)-4540.d0* WX4(J)+10496.d0*WX12(J)
     *           -928.d0* WX7(J)+5888.d0*WX13(J)+  989.d0* WX2(J)
            aa=aa+989.d0* WX2(J)+5888.d0*WX14(J)-  928.d0* WX8(J)
     *         +10496.d0*WX15(J)-4540.d0* WX5(J)+10496.d0*WX16(J)
     *                 -928.d0* WX9(J)+5888.d0*WX17(J)+  989.d0* WX3(J)
            GWX(J)= GWX(J)+H*aa/56700.d0
            aa=   989.d0* QZ1(J)+5888.d0*QZ10(J)-  928.d0* QZ6(J)
     *               +10496.d0*QZ11(J)-4540.d0* QZ4(J)+10496.d0*QZ12(J)
     *           -928.d0* QZ7(J)+5888.d0*QZ13(J)+  989.d0* QZ2(J)
            aa=aa+989.d0* QZ2(J)+5888.d0*QZ14(J)-  928.d0* QZ8(J)
     *         +10496.d0*QZ15(J)-4540.d0* QZ5(J)+10496.d0*QZ16(J)
     *                 -928.d0* QZ9(J)+5888.d0*QZ17(J)+  989.d0* QZ3(J)
            GQZ(J)= GQZ(J)+H*aa/56700.d0
            aa=   989.d0* WZ1(J)+5888.d0*WZ10(J)-  928.d0* WZ6(J)
     *               +10496.d0*WZ11(J)-4540.d0* WZ4(J)+10496.d0*WZ12(J)
     *           -928.d0* WZ7(J)+5888.d0*WZ13(J)+  989.d0* WZ2(J)
            aa=aa+989.d0* WZ2(J)+5888.d0*WZ14(J)-  928.d0* WZ8(J)
     *         +10496.d0*WZ15(J)-4540.d0* WZ5(J)+10496.d0*WZ16(J)
     *                 -928.d0* WZ9(J)+5888.d0*WZ17(J)+  989.d0* WZ3(J)
            GWZ(J)= GWZ(J)+H*aa/56700.d0
            QX1(J)= QX3(J) 
            VX1(J)= VX3(J) 
            WX1(J)= WX3(J) 
            QZ1(J)= QZ3(J) 
            WZ1(J)= WZ3(J) 
        end do 
        IF(IOT.eq.1)THEN 
            WRITE(21,1100)W10,QX10(0),VX10(0),WX10(0),QZ10(0),WZ10(0) 
     *                         ,QX10(1),VX10(1),WX10(1),QZ10(1),WZ10(1) 
     *                         ,QX10(2),VX10(2),WX10(2),QZ10(2),WZ10(2) 
            WRITE(21,1100)W6,QX6(0),VX6(0),WX6(0),QZ6(0),WZ6(0) 
     *                        ,QX6(1),VX6(1),WX6(1),QZ6(1),WZ6(1) 
     *                        ,QX6(2),VX6(2),WX6(2),QZ6(2),WZ6(2) 
            WRITE(21,1100)W11,QX11(0),VX11(0),WX11(0),QZ11(0),WZ11(0) 
     *                         ,QX11(1),VX11(1),WX11(1),QZ11(1),WZ11(1) 
     *                         ,QX11(2),VX11(2),WX11(2),QZ11(2),WZ11(2) 
            WRITE(21,1100)W4,QX4(0),VX4(0),WX4(0),QZ4(0),WZ4(0) 
     *                        ,QX4(1),VX4(1),WX4(1),QZ4(1),WZ4(1) 
     *                        ,QX4(2),VX4(2),WX4(2),QZ4(2),WZ4(2) 
            WRITE(21,1100)W12,QX12(0),VX12(0),WX12(0),QZ12(0),WZ12(0) 
     *                         ,QX12(1),VX12(1),WX12(1),QZ12(1),WZ12(1) 
     *                         ,QX12(2),VX12(2),WX12(2),QZ12(2),WZ12(2) 
            WRITE(21,1100)W7,QX7(0),VX7(0),WX7(0),QZ7(0),WZ7(0) 
     *                            ,QX7(1),VX7(1),WX7(1),QZ7(1),WZ7(1) 
     *                            ,QX7(2),VX7(2),WX7(2),QZ7(2),WZ7(2) 
            WRITE(21,1100)W13,QX13(0),VX13(0),WX13(0),QZ13(0),WZ13(0) 
     *                         ,QX13(1),VX13(1),WX13(1),QZ13(1),WZ13(1) 
     *                         ,QX13(2),VX13(2),WX13(2),QZ13(2),WZ13(2) 
            WRITE(21,1100)W2,QX2(0),VX2(0),WX2(0),QZ2(0),WZ2(0) 
     *                        ,QX2(1),VX2(1),WX2(1),QZ2(1),WZ2(1) 
     *                        ,QX2(2),VX2(2),WX2(2),QZ2(2),WZ2(2) 
            WRITE(21,1100)W14,QX14(0),VX14(0),WX14(0),QZ14(0),WZ14(0) 
     *                         ,QX14(1),VX14(1),WX14(1),QZ14(1),WZ14(1) 
     *                         ,QX14(2),VX14(2),WX14(2),QZ14(2),WZ14(2) 
            WRITE(21,1100)W8,QX8(0),VX8(0),WX8(0),QZ8(0),WZ8(0) 
     *                        ,QX8(1),VX8(1),WX8(1),QZ8(1),WZ8(1) 
     *                        ,QX8(2),VX8(2),WX8(2),QZ8(2),WZ8(2) 
            WRITE(21,1100)W15,QX15(0),VX15(0),WX15(0),QZ15(0),WZ15(0) 
     *                         ,QX15(1),VX15(1),WX15(1),QZ15(1),WZ15(1) 
     *                         ,QX15(2),VX15(2),WX15(2),QZ15(2),WZ15(2) 
            WRITE(21,1100)W5,QX5(0),VX5(0),WX5(0),QZ5(0),WZ5(0) 
     *                        ,QX5(1),VX5(1),WX5(1),QZ5(1),WZ5(1) 
     *                        ,QX5(2),VX5(2),WX5(2),QZ5(2),WZ5(2) 
            WRITE(21,1100)W16,QX16(0),VX16(0),WX16(0),QZ16(0),WZ16(0) 
     *                         ,QX16(1),VX16(1),WX16(1),QZ16(1),WZ16(1) 
     *                         ,QX16(2),VX16(2),WX16(2),QZ16(2),WZ16(2) 
            WRITE(21,1100)W9,QX9(0),VX9(0),WX9(0),QZ9(0),WZ9(0) 
     *                        ,QX9(1),VX9(1),WX9(1),QZ9(1),WZ9(1) 
     *                        ,QX9(2),VX9(2),WX9(2),QZ9(2),WZ9(2) 
            WRITE(21,1100)W17,QX17(0),VX17(0),WX17(0),QZ17(0),WZ17(0) 
     *                         ,QX17(1),VX17(1),WX17(1),QZ17(1),WZ17(1) 
     *                         ,QX17(2),VX17(2),WX17(2),QZ17(2),WZ17(2) 
            WRITE(21,1100)W3,QX3(0),VX3(0),WX3(0),QZ3(0),WZ3(0) 
     *                        ,QX3(1),VX3(1),WX3(1),QZ3(1),WZ3(1) 
     *                        ,QX3(2),VX3(2),WX3(2),QZ3(2),WZ3(2) 
          END IF 
c          goto 100 
 
  100 CONTINUE 
c 
c      write(*,*) 
c      write(*,*)'sInt1       ,sInt2        ',sInt1,sInt2 
c      write(*,*)'sImax1      ,sImax2       ',sImax1,sImax2 
c      write(*,*)'sInt1/sImax1,sInt2/sImax2=',sInt1/sImax1,sInt2/sImax2 
      if(((sInt1/sImax1).lt.0.00001d0) 
     *                  .and.((sInt2/sImax2).lt.0.00001d0))then 
c        write(*,*)'sInt1/sImax1 & sInt2/sImax2 < 0.00001d !!!' 
        goto 20 
      end if 
c 
      if(((sInt1/sImax1).lt.0.5d0).and.((sInt2/sImax2).lt.0.5d0))then 
        if(iter.gt.20)then 
          write(10,*)'iter > 20 !!' 
          goto 20 
        end if 
c        write(*,*)'sInt1/sImax1 & sInt2/sImax2 < 0.5d !!!'  
c        write(*,*)  
        w1=WNRs(3)*iter 
        w2=w1+WNRs(3) 
        if(ns.ge.2)then 
          ns=ns/2 
          sImax1=sImax1*2.d0 
          sImax2=sImax2*2.d0 
        end if 
        goto 10 
      end if 
c 
c   20      write(*,*) 
c      write(*,*)'Static Integration 2:' 
c      write(*,*)'Number of Integration Range =',iter 
c   20 write(*,*)'Number of Integ. Points for Static Range 2=',nint 
c   20 write(10,*)'Itr. & Intg. Pnt. Num. for Static Range 2=',iter,nint
   20 NWT2=NWT2+nint
c 
      return 
      end 
C 
C 
C *** THE INTEGRANDS OF Q, V, AND W AND THEIR DERIVATIVES for Static Range 2 *** 
C 
      SUBROUTINE INTEGS2(OM,WR,WI,QX,QZ,VX,WX,WZ) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 QX(0:2),QZ(0:2),VX(0:2),WX(0:2),WZ(0:2),OM 
     *   ,VLX(2),URX(2,2),URZ(2,2),VLXZ,URXZ(2),URZZ(2),SM,RAM 
     *   ,WN,im,RK,BJ0,BJ1,BN0,BN1,HK0(0:1),HK1(0:1),HKK(0:1),HKD(0:1) 
      COMMON /FCQVW/SM,RAM,RR
C 
c   * the displacement-stress vectors on the plus ki axis * 
c 
      im=(0.d0,1.d0) 
      RK=dcmplx(WR,+WI) 
      WN=RK/RR 
      CALL RTSHc(OM,WN,VLX) 
      CALL RTPSVc(OM,WN,URX,URZ) 
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.d0*SM)
      URZZ(2)=(URZ(2,2)-WN*RAM*URZ(1,1))/(RAM+2.d0*SM)
C 
c   * the complex Bessel & Hankell functions on the plus ki axis * 
c 
      call CBJN0(RK,BJ0,BN0) 
      call CBJN1(RK,BJ1,BN1) 
      HK0(0)=+0.5d0*im*(BJ0+im*BN0) 
      HK1(0)=+0.5d0*im*(BJ1+im*BN1) 
c 
      HKK(0)=HK1(0)/RK 
      HKD(0)=HK0(0)-HKK(0) 
      HK0(1)=-HK1(0)*WN 
      HK1(1)= HKD(0)*WN 
      HKK(1)=(HK1(1)-HK1(0)/RR)/RK 
      HKD(1)= HK0(1)-HKK(1) 
C 
c   * the integrands * 
c 
      QX(0)= URX(1,1)*HKD(0)+VLX(1)*HKK(0) 
      VX(0)= URX(1,1)*HKK(0)+VLX(1)*HKD(0) 
      WX(0)= URX(2,1)*HK1(0) 
      QZ(0)= URZ(1,1)*HK1(0) 
      WZ(0)= URZ(2,1)*HK0(0) 
      QX(1)= URX(1,1)*HKD(1)+VLX(1)*HKK(1) 
      VX(1)= URX(1,1)*HKK(1)+VLX(1)*HKD(1) 
      WX(1)= URX(2,1)*HK1(1) 
      QZ(1)= URZ(1,1)*HK1(1) 
      WZ(1)= URZ(2,1)*HK0(1) 
      QX(2)= URXZ(1)*HKD(0)+VLXZ*HKK(0) 
      VX(2)= URXZ(1)*HKK(0)+VLXZ*HKD(0)        
      WX(2)= URXZ(2)*HK1(0) 
      QZ(2)= URZZ(1)*HK1(0) 
      WZ(2)= URZZ(2)*HK0(0) 
C 
c   * the displacement-stress vectors on the minus ki axis * 
c 
      RK=dcmplx(WR,-WI) 
      WN=RK/RR 
      CALL RTSHc(OM,WN,VLX) 
      CALL RTPSVc(OM,WN,URX,URZ) 
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.d0*SM)
      URZZ(2)=(URZ(2,2)-WN*RAM*URZ(1,1))/(RAM+2.d0*SM)
C 
c   * the complex Bessel & Hankell functions on the minus ki axis * 
c 
      HK0(0)=dconjg(HK0(0)) 
      HK1(0)=dconjg(HK1(0)) 
c 
      HKK(0)=HK1(0)/RK 
      HKD(0)=HK0(0)-HKK(0) 
      HK0(1)=-HK1(0)*WN 
      HK1(1)= HKD(0)*WN 
      HKK(1)=(HK1(1)-HK1(0)/RR)/RK 
      HKD(1)= HK0(1)-HKK(1) 
C 
c   * the integrands * 
c 
      QX(0)= QX(0) + URX(1,1)*HKD(0)+VLX(1)*HKK(0) 
      VX(0)= VX(0) + URX(1,1)*HKK(0)+VLX(1)*HKD(0) 
      WX(0)= WX(0) + URX(2,1)*HK1(0) 
      QZ(0)= QZ(0) + URZ(1,1)*HK1(0) 
      WZ(0)= WZ(0) + URZ(2,1)*HK0(0) 
      QX(1)= QX(1) + URX(1,1)*HKD(1)+VLX(1)*HKK(1) 
      VX(1)= VX(1) + URX(1,1)*HKK(1)+VLX(1)*HKD(1) 
      WX(1)= WX(1) + URX(2,1)*HK1(1) 
      QZ(1)= QZ(1) + URZ(1,1)*HK1(1) 
      WZ(1)= WZ(1) + URZ(2,1)*HK0(1) 
      QX(2)= QX(2) + URXZ(1)*HKD(0)+VLXZ*HKK(0) 
      VX(2)= VX(2) + URXZ(1)*HKK(0)+VLXZ*HKD(0)        
      WX(2)= WX(2) + URXZ(2)*HK1(0) 
      QZ(2)= QZ(2) + URZZ(1)*HK1(0) 
      WZ(2)= WZ(2) + URZZ(2)*HK0(0) 
C 
      RETURN 
      END 
C 
c 
c 
C *** SH DISPLACEMENT USING R/T MATRIX *** 
C 
      SUBROUTINE RTSHc(OM,WN,VLX) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 VLX(2),WS2,CMS,SM,EE(2,2),OM,OM2,VSc,VS2 
     *          ,DD,DU,AU,BU,AD,BD,CS,GTD,GTU,GRD,GRU 
     *          ,CD(20),CU(20),CUSU,CDSU,CDSD,CUSD,WN,WN2,DQ 
      COMMON /SOLY/SDEP,ODEP,LS,LO 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     *       /GRTSH/GTD(0:20),GTU(0:20),GRD(0:20),GRU(0:20) 
C 
C *** CHECK FOR THE DIMENSION OF CD AND CU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM RTSHc: NL.GT.NC ',NL,NC 
         STOP 
      END IF 
C 
C *** COMPUTATION OF GENERALIZED R/T MATRICES *** 
C 
      CALL GNRTSHc(OM,WN) 
C 
C *** COMPUTATION OF VLX *** 
C 
      OM2=OM*OM 
      WN2=WN*WN 
C 
      QSe=FuncQS(OM,LS)
      VSc=VS(LS)*DCMPLX(1.D0,-0.5D0/QSe) 
      VS2=VSc*VSc 
      WS2=OM2/VS2 
      CMS=CDSQRT(WN2-WS2) 
      IF(dREAL(CMS).LT.0.d0)CMS=-CMS
C 
      SM=DNS(LS)*VS2 
      EE(1,1)=(1.d0,0.d0)
      EE(1,2)=(1.d0,0.d0)
      EE(2,1)=-SM*CMS 
      EE(2,2)= SM*CMS 
c 
      DQ=-WN/6.2831853072d0 
C 
c *** Up-/Down-Going Coefficients *** 
c 
      IF((LS.EQ.1).AND.(SDEP.EQ.0.d0))THEN
C 
          IF(NL.EQ.1)THEN 
            CDSD=DQ/EE(2,1) 
            CUSD=(0.d0,0.d0)
          ELSE 
            DD=CDEXP(-CMS*THK(1)) 
            CDSD=DQ/(EE(2,1)+EE(2,2)*DD*GRD(1)) 
            CUSD=GRD(1)*CDSD 
          END IF 
C 
      ELSE 
C  
          IF(LS.EQ.NL)THEN  
C 
            DD=CDEXP(-CMS*SDEP) 
            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 
            CUSU=DQ/(BD*CS-BU) 
            CDSU=GRU(LS-1)*CUSU 
            CDSD=CS*CUSU 
C 
          ELSE 
C 
            DD=CDEXP(-CMS*SDEP) 
            DU=CDEXP(-CMS*(THK(LS)-SDEP)) 
            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 
            CUSU=DQ/(BD*CS-BU) 
            CDSU=GRU(LS-1)*CUSU 
            CDSD=CS*CUSU 
            CUSD=GRD(LS)*CDSD 
C 
          ENDIF 
C 
      END IF 
C 
      IF(LS.EQ.1)GOTO 10 
      CU(LS-1)=GTU(LS-1)*CUSU 
      DO 100 J=LS-2,1,-1 
          CU(J)=GTU(J)*CU(J+1) 
          CD(J+1)=GRU(J)*CU(J+1) 
  100 CONTINUE 
      CD(1)=GRU(0)*CU(1) 
C 
   10 IF(LS.EQ.NL)GOTO 20 
      CD(LS+1)=GTD(LS)*CDSD 
      DO 120 J=LS+1,NL-1 
          CD(J+1)=GTD(J)*CD(J) 
          CU(J)=GRD(J)*CD(J) 
  120 CONTINUE 
C 
c *** Displacement-Stress Vectors for SH wave *** 
c 
   20 QSe=FuncQS(OM,LO)
      VSc=VS(LO)*DCMPLX(1.D0,-0.5D0/QSe) 
      VS2=VSc*VSc 
      WS2=OM2/VS2 
      CMS=CDSQRT(WN2-WS2) 
      IF(dREAL(CMS).LT.0.d0)CMS=-CMS
C 
      SM=DNS(LO)*VS2 
      EE(1,1)=(1.d0,0.d0)
      EE(1,2)=(1.d0,0.d0)
      EE(2,1)=-SM*CMS 
      EE(2,2)= SM*CMS 
c 
      IF(LO.EQ.NL)THEN 
C         
        IF(LO.NE.LS)THEN 
          DD=CDEXP(-CMS*ODEP) 
          VLX(1)=EE(1,1)*DD*CD(LO) 
          VLX(2)=EE(2,1)*DD*CD(LO) 
        ELSE 
          IF(ODEP.GE.SDEP)THEN 
            DD=CDEXP(-CMS*(ODEP-SDEP)) 
            VLX(1)=EE(1,1)*DD*CDSD 
            VLX(2)=EE(2,1)*DD*CDSD 
          ELSE 
            DD=CDEXP(-CMS*ODEP) 
            DU=CDEXP(-CMS*(SDEP-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSU+EE(1,2)*DU*CUSU 
            VLX(2)=EE(2,1)*DD*CDSU+EE(2,2)*DU*CUSU 
          END IF 
        END IF 
C 
      ELSE 
C         
        IF(LO.NE.LS)THEN 
          DD=CDEXP(-CMS*ODEP) 
          DU=CDEXP(-CMS*(THK(LO)-ODEP)) 
          VLX(1)=EE(1,1)*DD*CD(LO)+EE(1,2)*DU*CU(LO) 
          VLX(2)=EE(2,1)*DD*CD(LO)+EE(2,2)*DU*CU(LO) 
        ELSE 
          IF(ODEP.GE.SDEP)THEN 
            DD=CDEXP(-CMS*(ODEP-SDEP)) 
            DU=CDEXP(-CMS*(THK(LO)-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSD+EE(1,2)*DU*CUSD 
            VLX(2)=EE(2,1)*DD*CDSD+EE(2,2)*DU*CUSD 
          ELSE 
            DD=CDEXP(-CMS*ODEP) 
            DU=CDEXP(-CMS*(SDEP-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSU+EE(1,2)*DU*CUSU 
            VLX(2)=EE(2,1)*DD*CDSU+EE(2,2)*DU*CUSU 
          END IF 
        END IF 
C 
      END IF 
C 
      RETURN 
      END 
c 
C 
C 
C *** PSV DISPLACEMENT USING R/T MATRIX *** 
C 
      SUBROUTINE RTPSVc(OM,WN,URX,URZ) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 CMP,CMS,EE(4,4),DD(2,2),DU(2,2),OM 
     *    ,AU(2,2),BU(2,2),AD(2,2),BD(2,2),CS(2,2),E1(2,2),E2(2,2) 
     *          ,GTD,GTU,GRD,GRU,DT,URX(2,2),URZ(2,2),WN,DQX,DQZ 
     *    ,CDX(2,20),CUX(2,20),CUSUX(2),CDSUX(2),CDSDX(2),CUSDX(2)  
     *    ,CDZ(2,20),CUZ(2,20),CUSUZ(2),CDSUZ(2),CDSDZ(2),CUSDZ(2)  
      COMMON /SOLY/SDEP,ODEP,LS,LO 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     * /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 AND CU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM RTPSV: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** COMPUTATION OF GENERALIZED R/T MATRICES *** 
C 
      CALL GNRTPSVc(OM,WN) 
C 
C *** COMPUTATION OF CD AND CU *** 
C 
      CALL MTXPSVc(OM,WN,LS,CMS,CMP,EE) 
C 
      DQX=-WN/6.2831853072d0 
      DQZ= WN/6.2831853072d0 
C 
      IF((LS.EQ.1).AND.(SDEP.EQ.0.d0))THEN
C 
        IF(NL.EQ.1)THEN 
            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 
            CDSDX(1)=E2(1,1)*DQX 
            CDSDX(2)=E2(2,1)*DQX 
            CUSDX(1)=(0.d0,0.d0)
            CUSDX(2)=(0.d0,0.d0)
            CDSDZ(1)=E2(1,2)*DQZ
            CDSDZ(2)=E2(2,2)*DQZ 
            CUSDZ(1)=(0.d0,0.d0)
            CUSDZ(2)=(0.d0,0.d0)
        ELSE 
            CALL DDUPSVc(OM,WN,THK(1),CMS,CMP,DU) 
            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 
            CDSDX(1)=E2(1,1)*DQX 
            CDSDX(2)=E2(2,1)*DQX 
            CUSDX(1)=GRD(1,1,1)*CDSDX(1)+GRD(1,2,1)*CDSDX(2) 
            CUSDX(2)=GRD(2,1,1)*CDSDX(1)+GRD(2,2,1)*CDSDX(2) 
            CDSDZ(1)=E2(1,2)*DQZ 
            CDSDZ(2)=E2(2,2)*DQZ 
            CUSDZ(1)=GRD(1,1,1)*CDSDZ(1)+GRD(1,2,1)*CDSDZ(2) 
            CUSDZ(2)=GRD(2,1,1)*CDSDZ(1)+GRD(2,2,1)*CDSDZ(2) 
        END IF 
C  
      ELSE 
C 
        IF(LS.EQ.NL)THEN  
            CALL DDUPSVc(OM,WN,SDEP,CMS,CMP,DD) 
            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)   
            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) 
            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) 
            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 
            CUSUX(1)=E2(1,1)*DQX 
            CUSUX(2)=E2(2,1)*DQX 
            CDSUX(1)=GRU(1,1,LS-1)*CUSUX(1)+GRU(1,2,LS-1)*CUSUX(2) 
            CDSUX(2)=GRU(2,1,LS-1)*CUSUX(1)+GRU(2,2,LS-1)*CUSUX(2) 
            CDSDX(1)=CS(1,1)*CUSUX(1)+CS(1,2)*CUSUX(2) 
            CDSDX(2)=CS(2,1)*CUSUX(1)+CS(2,2)*CUSUX(2) 
            CUSUZ(1)=E2(1,2)*DQZ 
            CUSUZ(2)=E2(2,2)*DQZ 
            CDSUZ(1)=GRU(1,1,LS-1)*CUSUZ(1)+GRU(1,2,LS-1)*CUSUZ(2) 
            CDSUZ(2)=GRU(2,1,LS-1)*CUSUZ(1)+GRU(2,2,LS-1)*CUSUZ(2) 
            CDSDZ(1)=CS(1,1)*CUSUZ(1)+CS(1,2)*CUSUZ(2) 
            CDSDZ(2)=CS(2,1)*CUSUZ(1)+CS(2,2)*CUSUZ(2) 
        ELSE 
            CALL DDUPSVc(OM,WN,SDEP,CMS,CMP,DD) 
            CALL DDUPSVc(OM,WN,THK(LS)-SDEP,CMS,CMP,DU) 
            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) 
            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) 
            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) 
            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) 
            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) 
            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 
            CUSUX(1)=E2(1,1)*DQX 
            CUSUX(2)=E2(2,1)*DQX 
            CDSUX(1)=GRU(1,1,LS-1)*CUSUX(1)+GRU(1,2,LS-1)*CUSUX(2) 
            CDSUX(2)=GRU(2,1,LS-1)*CUSUX(1)+GRU(2,2,LS-1)*CUSUX(2) 
            CDSDX(1)=CS(1,1)*CUSUX(1)+CS(1,2)*CUSUX(2) 
            CDSDX(2)=CS(2,1)*CUSUX(1)+CS(2,2)*CUSUX(2) 
            CUSDX(1)=GRD(1,1,LS)*CDSDX(1)+GRD(1,2,LS)*CDSDX(2) 
            CUSDX(2)=GRD(2,1,LS)*CDSDX(1)+GRD(2,2,LS)*CDSDX(2) 
            CUSUZ(1)=E2(1,2)*DQZ 
            CUSUZ(2)=E2(2,2)*DQZ 
            CDSUZ(1)=GRU(1,1,LS-1)*CUSUZ(1)+GRU(1,2,LS-1)*CUSUZ(2) 
            CDSUZ(2)=GRU(2,1,LS-1)*CUSUZ(1)+GRU(2,2,LS-1)*CUSUZ(2) 
            CDSDZ(1)=CS(1,1)*CUSUZ(1)+CS(1,2)*CUSUZ(2) 
            CDSDZ(2)=CS(2,1)*CUSUZ(1)+CS(2,2)*CUSUZ(2) 
            CUSDZ(1)=GRD(1,1,LS)*CDSDZ(1)+GRD(1,2,LS)*CDSDZ(2) 
            CUSDZ(2)=GRD(2,1,LS)*CDSDZ(1)+GRD(2,2,LS)*CDSDZ(2) 
        ENDIF 
C 
      END IF 
C 
      IF(LS.EQ.1)GOTO 10 
        CUX(1,LS-1)=GTU(1,1,LS-1)*CUSUX(1)+GTU(1,2,LS-1)*CUSUX(2) 
        CUX(2,LS-1)=GTU(2,1,LS-1)*CUSUX(1)+GTU(2,2,LS-1)*CUSUX(2) 
        CUZ(1,LS-1)=GTU(1,1,LS-1)*CUSUZ(1)+GTU(1,2,LS-1)*CUSUZ(2) 
        CUZ(2,LS-1)=GTU(2,1,LS-1)*CUSUZ(1)+GTU(2,2,LS-1)*CUSUZ(2) 
        DO 100 I=LS-2,1,-1 
          CUX(1,I)  =GTU(1,1,I)*CUX(1,I+1)+GTU(1,2,I)*CUX(2,I+1) 
          CUX(2,I)  =GTU(2,1,I)*CUX(1,I+1)+GTU(2,2,I)*CUX(2,I+1) 
          CDX(1,I+1)=GRU(1,1,I)*CUX(1,I+1)+GRU(1,2,I)*CUX(2,I+1) 
          CDX(2,I+1)=GRU(2,1,I)*CUX(1,I+1)+GRU(2,2,I)*CUX(2,I+1) 
          CUZ(1,I)  =GTU(1,1,I)*CUZ(1,I+1)+GTU(1,2,I)*CUZ(2,I+1) 
          CUZ(2,I)  =GTU(2,1,I)*CUZ(1,I+1)+GTU(2,2,I)*CUZ(2,I+1) 
          CDZ(1,I+1)=GRU(1,1,I)*CUZ(1,I+1)+GRU(1,2,I)*CUZ(2,I+1) 
          CDZ(2,I+1)=GRU(2,1,I)*CUZ(1,I+1)+GRU(2,2,I)*CUZ(2,I+1) 
  100   CONTINUE 
        CDX(1,1)=GRU(1,1,0)*CUX(1,1)+GRU(1,2,0)*CUX(2,1) 
        CDX(2,1)=GRU(2,1,0)*CUX(1,1)+GRU(2,2,0)*CUX(2,1) 
        CDZ(1,1)=GRU(1,1,0)*CUZ(1,1)+GRU(1,2,0)*CUZ(2,1) 
        CDZ(2,1)=GRU(2,1,0)*CUZ(1,1)+GRU(2,2,0)*CUZ(2,1) 
C 
   10 IF(LS.EQ.NL)GOTO 20 
        CDX(1,LS+1)=GTD(1,1,LS)*CDSDX(1)+GTD(1,2,LS)*CDSDX(2) 
        CDX(2,LS+1)=GTD(2,1,LS)*CDSDX(1)+GTD(2,2,LS)*CDSDX(2) 
        CDZ(1,LS+1)=GTD(1,1,LS)*CDSDZ(1)+GTD(1,2,LS)*CDSDZ(2) 
        CDZ(2,LS+1)=GTD(2,1,LS)*CDSDZ(1)+GTD(2,2,LS)*CDSDZ(2) 
        DO 120 I=LS+1,NL-1 
          CDX(1,I+1)=GTD(1,1,I)*CDX(1,I)+GTD(1,2,I)*CDX(2,I) 
          CDX(2,I+1)=GTD(2,1,I)*CDX(1,I)+GTD(2,2,I)*CDX(2,I) 
          CUX(1,I)  =GRD(1,1,I)*CDX(1,I)+GRD(1,2,I)*CDX(2,I) 
          CUX(2,I)  =GRD(2,1,I)*CDX(1,I)+GRD(2,2,I)*CDX(2,I) 
          CDZ(1,I+1)=GTD(1,1,I)*CDZ(1,I)+GTD(1,2,I)*CDZ(2,I) 
          CDZ(2,I+1)=GTD(2,1,I)*CDZ(1,I)+GTD(2,2,I)*CDZ(2,I) 
          CUZ(1,I)  =GRD(1,1,I)*CDZ(1,I)+GRD(1,2,I)*CDZ(2,I) 
          CUZ(2,I)  =GRD(2,1,I)*CDZ(1,I)+GRD(2,2,I)*CDZ(2,I) 
  120   CONTINUE 
C 
C *** COMPUTATION OF URX AND URZ *** 
C 
  20  CALL MTXPSVc(OM,WN,LO,CMS,CMP,EE) 
c 
      IF(LO.EQ.NL)THEN 
C         
        IF(LO.NE.LS)THEN 
C 
          CALL DDUPSVc(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(1,LO)+E1(1,2)*CDX(2,LO) 
          URX(2,1)=E1(2,1)*CDX(1,LO)+E1(2,2)*CDX(2,LO) 
          URZ(1,1)=E1(1,1)*CDZ(1,LO)+E1(1,2)*CDZ(2,LO) 
          URZ(2,1)=E1(2,1)*CDZ(1,LO)+E1(2,2)*CDZ(2,LO) 
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(1,LO)+E1(1,2)*CDX(2,LO) 
          URX(2,2)=E1(2,1)*CDX(1,LO)+E1(2,2)*CDX(2,LO) 
          URZ(1,2)=E1(1,1)*CDZ(1,LO)+E1(1,2)*CDZ(2,LO) 
          URZ(2,2)=E1(2,1)*CDZ(1,LO)+E1(2,2)*CDZ(2,LO) 
C 
        ELSE 
C 
          IF(ODEP.GE.SDEP)THEN 
C 
            CALL DDUPSVc(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(1)+E1(1,2)*CDSDX(2) 
            URX(2,1)=E1(2,1)*CDSDX(1)+E1(2,2)*CDSDX(2) 
            URZ(1,1)=E1(1,1)*CDSDZ(1)+E1(1,2)*CDSDZ(2) 
            URZ(2,1)=E1(2,1)*CDSDZ(1)+E1(2,2)*CDSDZ(2) 
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(1)+E1(1,2)*CDSDX(2) 
            URX(2,2)=E1(2,1)*CDSDX(1)+E1(2,2)*CDSDX(2) 
            URZ(1,2)=E1(1,1)*CDSDZ(1)+E1(1,2)*CDSDZ(2) 
            URZ(2,2)=E1(2,1)*CDSDZ(1)+E1(2,2)*CDSDZ(2) 
C 
          ELSE 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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(1)+E1(1,2)*CDSUX(2) 
     *              +E2(1,1)*CUSUX(1)+E2(1,2)*CUSUX(2) 
            URX(2,1)=E1(2,1)*CDSUX(1)+E1(2,2)*CDSUX(2) 
     *              +E2(2,1)*CUSUX(1)+E2(2,2)*CUSUX(2) 
            URZ(1,1)=E1(1,1)*CDSUZ(1)+E1(1,2)*CDSUZ(2) 
     *              +E2(1,1)*CUSUZ(1)+E2(1,2)*CUSUZ(2) 
            URZ(2,1)=E1(2,1)*CDSUZ(1)+E1(2,2)*CDSUZ(2) 
     *              +E2(2,1)*CUSUZ(1)+E2(2,2)*CUSUZ(2) 
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(1)+E1(1,2)*CDSUX(2) 
     *              +E2(1,1)*CUSUX(1)+E2(1,2)*CUSUX(2) 
            URX(2,2)=E1(2,1)*CDSUX(1)+E1(2,2)*CDSUX(2) 
     *              +E2(2,1)*CUSUX(1)+E2(2,2)*CUSUX(2) 
            URZ(1,2)=E1(1,1)*CDSUZ(1)+E1(1,2)*CDSUZ(2) 
     *              +E2(1,1)*CUSUZ(1)+E2(1,2)*CUSUZ(2) 
            URZ(2,2)=E1(2,1)*CDSUZ(1)+E1(2,2)*CDSUZ(2) 
     *              +E2(2,1)*CUSUZ(1)+E2(2,2)*CUSUZ(2) 
C 
          END IF 
C 
        END IF 
C 
      ELSE 
C         
        IF(LO.NE.LS)THEN 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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(1,LO)+E1(1,2)*CDX(2,LO) 
     *              +E2(1,1)*CUX(1,LO)+E2(1,2)*CUX(2,LO) 
            URX(2,1)=E1(2,1)*CDX(1,LO)+E1(2,2)*CDX(2,LO) 
     *              +E2(2,1)*CUX(1,LO)+E2(2,2)*CUX(2,LO) 
            URZ(1,1)=E1(1,1)*CDZ(1,LO)+E1(1,2)*CDZ(2,LO) 
     *              +E2(1,1)*CUZ(1,LO)+E2(1,2)*CUZ(2,LO) 
            URZ(2,1)=E1(2,1)*CDZ(1,LO)+E1(2,2)*CDZ(2,LO) 
     *              +E2(2,1)*CUZ(1,LO)+E2(2,2)*CUZ(2,LO) 
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(1,LO)+E1(1,2)*CDX(2,LO) 
     *              +E2(1,1)*CUX(1,LO)+E2(1,2)*CUX(2,LO) 
            URX(2,2)=E1(2,1)*CDX(1,LO)+E1(2,2)*CDX(2,LO) 
     *              +E2(2,1)*CUX(1,LO)+E2(2,2)*CUX(2,LO) 
            URZ(1,2)=E1(1,1)*CDZ(1,LO)+E1(1,2)*CDZ(2,LO) 
     *              +E2(1,1)*CUZ(1,LO)+E2(1,2)*CUZ(2,LO) 
            URZ(2,2)=E1(2,1)*CDZ(1,LO)+E1(2,2)*CDZ(2,LO) 
     *              +E2(2,1)*CUZ(1,LO)+E2(2,2)*CUZ(2,LO) 
C 
        ELSE 
C 
          IF(ODEP.GE.SDEP)THEN 
C 
            CALL DDUPSVc(OM,WN,ODEP-SDEP,CMS,CMP,DD) 
            CALL DDUPSVc(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(1)+E1(1,2)*CDSDX(2) 
     *              +E2(1,1)*CUSDX(1)+E2(1,2)*CUSDX(2) 
            URX(2,1)=E1(2,1)*CDSDX(1)+E1(2,2)*CDSDX(2) 
     *              +E2(2,1)*CUSDX(1)+E2(2,2)*CUSDX(2) 
            URZ(1,1)=E1(1,1)*CDSDZ(1)+E1(1,2)*CDSDZ(2) 
     *              +E2(1,1)*CUSDZ(1)+E2(1,2)*CUSDZ(2) 
            URZ(2,1)=E1(2,1)*CDSDZ(1)+E1(2,2)*CDSDZ(2) 
     *              +E2(2,1)*CUSDZ(1)+E2(2,2)*CUSDZ(2) 
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(1)+E1(1,2)*CDSDX(2) 
     *              +E2(1,1)*CUSDX(1)+E2(1,2)*CUSDX(2) 
            URX(2,2)=E1(2,1)*CDSDX(1)+E1(2,2)*CDSDX(2) 
     *              +E2(2,1)*CUSDX(1)+E2(2,2)*CUSDX(2) 
            URZ(1,2)=E1(1,1)*CDSDZ(1)+E1(1,2)*CDSDZ(2) 
     *              +E2(1,1)*CUSDZ(1)+E2(1,2)*CUSDZ(2) 
            URZ(2,2)=E1(2,1)*CDSDZ(1)+E1(2,2)*CDSDZ(2) 
     *              +E2(2,1)*CUSDZ(1)+E2(2,2)*CUSDZ(2) 
C 
          ELSE 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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(1)+E1(1,2)*CDSUX(2) 
     *              +E2(1,1)*CUSUX(1)+E2(1,2)*CUSUX(2) 
            URX(2,1)=E1(2,1)*CDSUX(1)+E1(2,2)*CDSUX(2) 
     *              +E2(2,1)*CUSUX(1)+E2(2,2)*CUSUX(2) 
            URZ(1,1)=E1(1,1)*CDSUZ(1)+E1(1,2)*CDSUZ(2) 
     *              +E2(1,1)*CUSUZ(1)+E2(1,2)*CUSUZ(2) 
            URZ(2,1)=E1(2,1)*CDSUZ(1)+E1(2,2)*CDSUZ(2) 
     *              +E2(2,1)*CUSUZ(1)+E2(2,2)*CUSUZ(2) 
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(1)+E1(1,2)*CDSUX(2) 
     *              +E2(1,1)*CUSUX(1)+E2(1,2)*CUSUX(2) 
            URX(2,2)=E1(2,1)*CDSUX(1)+E1(2,2)*CDSUX(2) 
     *              +E2(2,1)*CUSUX(1)+E2(2,2)*CUSUX(2) 
            URZ(1,2)=E1(1,1)*CDSUZ(1)+E1(1,2)*CDSUZ(2) 
     *              +E2(1,1)*CUSUZ(1)+E2(1,2)*CUSUZ(2) 
            URZ(2,2)=E1(2,1)*CDSUZ(1)+E1(2,2)*CDSUZ(2) 
     *              +E2(2,1)*CUSUZ(1)+E2(2,2)*CUSUZ(2) 
C 
          END IF 
C 
        END IF 
C 
      END IF 
C 
      RETURN 
      END 
C 
c 
C *** SH GENERALIZED R/T MATIX *** 
C 
      SUBROUTINE GNRTSHc(OM,WN) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 GTD,GTU,GRD,GRU,TD,TU,RD,RU,OM,WN 
      COMMON /SOLY/SDEP,ODEP,LS,LO 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
      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(10,*)' FROM GNRTSH: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** MODIFIED R/T MATRIX *** 
C 
      CALL MDRTSHc(OM,WN) 
C 
C *** GENERALIZED R/T MATRIX *** 
C 
      GRU(0)=RU(0) 
      DO 100 I=1,LS-1 
        GTU(I)=TU(I)/(1.D0-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.D0-RU(I)*GRD(I+1)) 
        GRD(I)=RD(I)+TU(I)*GRD(I+1)*GTD(I) 
  200 CONTINUE 
C 
      RETURN 
      END 
C 
C 
C *** SH MODIFIED R/T MATIX *** 
C 
      SUBROUTINE MDRTSHc(OM,WN) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 WS2,CMS,SM,EA(2,2),EB(2,2),VSc,VS2 
     *      ,TD,TU,RD,RU,DDA,DUB,EAB,OM,OM2,WN,WN2 
      COMMON /SOLY/SDEP,ODEP,LS,LO 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
      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(10,*)' FROM MDRTSH: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** MODIFIED R/T MATRIX *** 
C 
      WN2=WN*WN 
      OM2=OM*OM 
C 
      QSe=FuncQS(OM,1)
      VSc=VS(1)*DCMPLX(1.D0,-0.5D0/QSe) 
      VS2=VSc*VSc 
      WS2=OM2/VS2 
      CMS=CDSQRT(WN2-WS2) 
      IF(DREAL(CMS).LT.0.D0)CMS=-CMS 
C 
      SM=DNS(1)*VS2 
      EA(1,1)=(1.D0,0.D0) 
      EA(1,2)=(1.D0,0.D0) 
      EA(2,1)=-SM*CMS 
      EA(2,2)= SM*CMS 
C 
      IF(NL.EQ.1)THEN 
        DUB=CDEXP(-CMS*SDEP) 
c        RU(0)=-EA(2,2)*DUB/EA(2,1) 
        RU(0)=DUB 
        RETURN 
      END IF 
C 
      IF(LS.EQ.1)THEN 
        DUB=CDEXP(-CMS*SDEP) 
        DDA=CDEXP(-CMS*(THK(1)-SDEP)) 
      ELSE 
        DUB=CDEXP(-CMS*THK(1)) 
        DDA=DUB 
      END IF 
C 
c      RU(0)=-EA(2,2)*DUB/EA(2,1) 
      RU(0)=DUB 
C 
      DO 100 I=1, NL-2 
C 
        QSe=FuncQS(OM,I+1)
        VSc=VS(I+1)*DCMPLX(1.D0,-0.5D0/QSe) 
        VS2=VSc*VSc
        WS2=OM2/VS2
        CMS=CDSQRT(WN2-WS2) 
        IF(DREAL(CMS).LT.0.D0)CMS=-CMS 
C 
        SM=DNS(I+1)*VS2 
        EB(1,1)=(1.D0,0.D0) 
        EB(1,2)=(1.D0,0.D0) 
        EB(2,1)=-SM*CMS 
        EB(2,2)= SM*CMS 
C 
        IF(LS.EQ.(I+1))THEN 
          DUB=CDEXP(-CMS*SDEP) 
        ELSE 
          DUB=CDEXP(-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=CDEXP(-CMS*(THK(I+1)-SDEP)) 
        ELSE           
          DDA=DUB 
        END IF 
C 
  100 CONTINUE 
C         
      QSe=FuncQS(OM,NL)
      VSc=VS(NL)*DCMPLX(1.D0,-0.5D0/QSe) 
      VS2=VSc*VSc 
      WS2=OM2/VS2 
      CMS=CDSQRT(WN2-WS2) 
      IF(DREAL(CMS).LT.0.D0)CMS=-CMS 
C 
      SM=DNS(NL)*VS2 
      EB(1,1)=(1.D0,0.D0) 
      EB(1,2)=(1.D0,0.D0) 
      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=CDEXP(-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 *** P-SV GENERALIZED R/T MATIX *** 
C 
      SUBROUTINE GNRTPSVc(OM,WN) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 GTD,GTU,GRD,GRU,TD,TU,RD,RU,E1(2,2),E2(2,2) 
      COMPLEX*16 DT,OM,WN 
      COMMON /SOLY/SDEP,ODEP,LS,LO 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
      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(10,*)' FROM GNRTPSV: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** MODIFIED R/T MATRIX *** 
C 
      CALL MDRTPSVc(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.D0-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.D0-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.D0-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.D0-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 
C 
C *** P-SV MODIFIED R/T MATIX *** 
C 
      SUBROUTINE MDRTPSVc(OM,WN) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 CMS,CMP,EA(4,4),EB(4,4),TD,TU,RD,RU 
     *       ,DDA(2,2),DUB(2,2),DET,OM,WN 
      COMMON /SOLY/SDEP,ODEP,LS,LO 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     *    /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(10,*)' FROM MDRTPSVc: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** MODIFIED R/T MATRIX *** 
C 
      CALL MTXPSVc(OM,WN,1,CMS,CMP,EA) 
C 
      IF(LS.EQ.1)THEN 
        CALL DDUPSVc(OM,WN,SDEP,CMS,CMP,DUB) 
      ELSE 
        CALL DDUPSVc(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 DDUPSVc(OM,WN,THK(1)-SDEP,CMS,CMP,DDA) 
      ELSE 
        CALL DDUPSVc(OM,WN,THK(1),CMS,CMP,DDA) 
      END IF 
C 
      DO 100 I=1, NL-1 
C 
        CALL MTXPSVc(OM,WN,I+1,CMS,CMP,EB) 
C 
        IF(LS.EQ.(I+1))THEN 
          CALL DDUPSVc(OM,WN,SDEP,CMS,CMP,DUB) 
        ELSE 
          CALL DDUPSVc(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 DDUPSVc(OM,WN,THK(I+1)-SDEP,CMS,CMP,DDA) 
          END IF 
        ELSE 
          CALL DDUPSVc(OM,WN,THK(I+1),CMS,CMP,DDA) 
        END IF 
C 
  100 CONTINUE 
C 
      RETURN 
      END 
C 
C 
C *** P-SV ELEMENT MATIX *** 
C 
      SUBROUTINE MTXPSVc(OM,WN,L,CMS,CMP,EE) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 WS2,CMS,WP2,CMP,EE(4,4),X0,AA,CMSG,CMPG 
     *                ,OM,OM2,WN,WN2,VSc,VS2,VPc,VP2,SM 
      COMMON/STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                   ,VS(20),QS(20),FS(20),THK(20),NL 
C 
C *** CHECK FOR THE DIMENSION OF COMMOM *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM MTXPSVc: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** ELEMENT MATRIX *** 
C 
      QPe=FuncQP(OM,L)
      QSe=FuncQS(OM,L)
      VPc=VP(L)*DCMPLX(1.D0,-0.5D0/QPe) 
      VSc=VS(L)*DCMPLX(1.D0,-0.5D0/QSe) 
      VP2=VPc*VPc 
      VS2=VSc*VSc 
      SM=DNS(L)*VS2 
C 
      IF(dreal(OM).EQ.0.D0)THEN 
C   
        X0=(1.D0+VS2/VP2)/(1.D0-VS2/VP2) 
        AA=WN*SM 
C 
        EE(1,1)=(1.D0,0.D0) 
        EE(1,2)=(1.D0,0.D0) 
        EE(1,3)=(1.D0,0.D0) 
        EE(1,4)=(1.D0,0.D0) 
        EE(2,1)=-(X0-1.D0) 
        EE(2,2)=(1.D0,0.D0) 
        EE(2,3)= X0-1.D0 
        EE(2,4)=(-1.D0,0.D0) 
        EE(3,1)= (X0-3.D0)*AA 
        EE(3,2)= -2.D0*AA 
        EE(3,3)=-(X0-3.D0)*AA 
        EE(3,4)= 2.D0*AA 
        EE(4,1)= (X0-1.D0)*AA 
        EE(4,2)= -2.D0*AA 
        EE(4,3)= (X0-1.D0)*AA 
        EE(4,4)=-2.D0*AA 
C 
      ELSE 
C 
        WN2=WN*WN 
        OM2=OM*OM 
c 
        WS2=OM2/VS2 
        CMS=CDSQRT(WN2-WS2) 
        IF(DREAL(CMS).LT.0.D0)CMS=-CMS 
        CMSG=CMS/WN 
C 
        WP2=OM2/VP2 
        CMP=CDSQRT(WN2-WP2) 
        IF(DREAL(CMP).LT.0.D0)CMP=-CMP 
        CMPG=CMP/WN 
C 
        X0=2.D0*WN-WS2/WN 
C 
        EE(1,1)=(-1.D0,0.D0) 
        EE(1,2)= CMSG 
        EE(1,3)=(-1.D0,0.D0) 
        EE(1,4)= CMSG 
        EE(2,1)=-CMPG 
        EE(2,2)=(1.D0,0.D0) 
        EE(2,3)= CMPG 
        EE(2,4)=(-1.D0,0.D0) 
        EE(3,1)= 2.D0*SM*CMP  
        EE(3,2)=-SM*X0  
        EE(3,3)=-2.D0*SM*CMP  
        EE(3,4)= SM*X0  
        EE(4,1)= SM*X0  
        EE(4,2)=-2.D0*SM*CMS  
        EE(4,3)= SM*X0  
        EE(4,4)=-2.D0*SM*CMS  
C 
      END IF 
C 
      RETURN 
      END 
C 
C 
C *** P-SV UP/DOWN-GOING MATRIX *** 
C 
      SUBROUTINE DDUPSVc(OM,WN,THK,CMS,CMP,DU) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 DU(2,2),CMS,CMP,OM,WN,EW 
C 
      IF(dreal(OM).EQ.0.D0)THEN 
        EW=cDEXP(-WN*THK) 
        DU(1,1)= EW 
        DU(1,2)= (0.D0,0.D0) 
        DU(2,1)= -WN*THK*EW 
        DU(2,2)= EW 
      ELSE 
        DU(1,1)= CDEXP(-CMP*THK) 
        DU(1,2)= (0.D0,0.D0) 
        DU(2,1)= (0.D0,0.D0) 
        DU(2,2)= CDEXP(-CMS*THK) 
      END IF 
C 
      RETURN 
      END 
C 
C 
C *** P-SV MODIFIED R/T MATRIX FOR Ith LAYER *** 
C 
        SUBROUTINE MTRPSV(EA,EB,DDA,DUB,L)  
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 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) 
     *          ,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 /MRTPSV/TD(2,2,0:20),TU(2,2,0:20),RD(2,2,0:20),RU(2,2,0:20) 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
C 
C *** CHECK FOR THE DIMENSION OF COMMON *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' 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.D0,0.D0) 
          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 *** THE COMPUTATION OF Q, V, AND W AND THEIR DERIVATIVES  
C     USING SIMPSON'S INTEGATION FOMULA (before k*r < 8)*** 
C 
      SUBROUTINE QVWRZS0(OM,GQX,GQZ,GVX,GWX,GWZ) 
C      
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 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),OM 
     *          ,QXB(0:2),QZB(0:2),VXB(0:2),WXB(0:2),WZB(0:2),SM 
     *          ,QXC(0:2),QZC(0:2),VXC(0:2),WXC(0:2),WZC(0:2),RAM 
      COMMON /INTG/VPMAX,VSMAX,RYMIN,CFINAL,N11,N12,M11 
     *       /WVNUM/WVN(2001),DWN,WNR(3),NWN 
     *       /FCQVW/SM,RAM,RR  /IRANGE/NRNG,IRNG 
     *             /sInteg/sImax1,sImax2 
C 
c *** Dimension Check *** 
c 
      NC=2001 
      IF(NWN.GT.NC)THEN 
         WRITE(10,*)' FROM QVWRZS: NWN.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C   * RANGE 1 : From near Zero to near om/Rayleigh(min) * 
C 
      sImax1=0.d0 
      sImax2=0.d0 
      NRNG=0 
      IRNG=0 
C 
      WA=WNR(1) 
      K=1 
      CALL INTEGS0(OM,K,WA,QXA,QZA,VXA,WXA,WZA) 
      DO  100 I=1,M11 
        K=2*I 
        WB=WVN(K) 
        CALL INTEGS0(OM,K,WB,QXB,QZB,VXB,WXB,WZB) 
        K=K+1 
        WC=WVN(K) 
        CALL INTEGS0(OM,K,WC,QXC,QZC,VXC,WXC,WZC) 
c 
        H=WC-WB 
        DO 110 J=0,2 
         GQX(J)= GQX(J)+H*(QXA(J)+4.d0*QXB(J)+QXC(J))/3.d0
         GVX(J)= GVX(J)+H*(VXA(J)+4.d0*VXB(J)+VXC(J))/3.d0
         GWX(J)= GWX(J)+H*(WXA(J)+4.d0*WXB(J)+WXC(J))/3.d0
         GQZ(J)= GQZ(J)+H*(QZA(J)+4.d0*QZB(J)+QZC(J))/3.d0
         GWZ(J)= GWZ(J)+H*(WZA(J)+4.d0*WZB(J)+WZC(J))/3.d0
         QXA(J)= QXC(J) 
         VXA(J)= VXC(J) 
         WXA(J)= WXC(J) 
         QZA(J)= QZC(J) 
         WZA(J)= WZC(J) 
  110   CONTINUE 
c 
c     * Check      of Convergence of Integrands * 
c 
        sI11=cdabs(QZA(2)+4.d0*QZB(2)+QZB(2))/3.d0
        sI12=cdabs(WZA(2)+4.d0*WZB(2)+WZB(2))/3.d0
        if(sI11.ge.sImax1)sImax1=sI11 
        if(sI12.ge.sImax2)sImax2=sI12 
c      write(2,999)k,si11,simax1,si11/simax1,si12,simax2,si12/simax2 
c 999  format(i5,6e12.4) 
        if(((sI11/sImax1).lt.0.0001d0).and. 
     *                       ((sI12/sImax2).lt.0.0001d0))then 
c          write(*,*)' Simpson Range 1: k*R & Int.Num.=',WC*RR,K 
c          write(*,*)'sI11,sI12',sI11,sI12 
c          write(*,*)'sImax1,sImax2',sImax1,sImax2 
c          write(*,*)'sI11/sImax1 < 0.0001d !!: sI11/sImax1=',sI11/sImax1 
c          write(*,*)'sI12/sImax2 < 0.0001d !!: sI12/sImax2=',sI12/sImax2 
          goto 10 
        end if 
c 
        IF(RR*WC.GT.8.D0)THEN 
          NRNG=1 
          IRNG=I 
          IF(I.EQ.M11)THEN 
            NRNG=2 
            IRNG=0 
          END IF 
          RETURN 
        END IF 
c 
  100 CONTINUE 
c 
C   * RANGE 2 : From near om/Rayleigh(min) to near om/C(final) * 
C 
      H=DWN 
      WA=WNR(2) 
      DO  200 I=1,N12 
        K=2*(M11+I) 
        WB=WVN(K) 
        CALL INTEGS0(OM,K,WB,QXB,QZB,VXB,WXB,WZB) 
        K=K+1 
        WC=WVN(K) 
        CALL INTEGS0(OM,K,WC,QXC,QZC,VXC,WXC,WZC) 
c 
        DO 210 J=0,2 
         GQX(J)= GQX(J)+H*(QXA(J)+4.d0*QXB(J)+QXC(J))/3.d0
         GVX(J)= GVX(J)+H*(VXA(J)+4.d0*VXB(J)+VXC(J))/3.d0
         GWX(J)= GWX(J)+H*(WXA(J)+4.d0*WXB(J)+WXC(J))/3.d0
         GQZ(J)= GQZ(J)+H*(QZA(J)+4.d0*QZB(J)+QZC(J))/3.d0
         GWZ(J)= GWZ(J)+H*(WZA(J)+4.d0*WZB(J)+WZC(J))/3.d0
         QXA(J)= QXC(J) 
         VXA(J)= VXC(J) 
         WXA(J)= WXC(J) 
         QZA(J)= QZC(J) 
         WZA(J)= WZC(J) 
  210   CONTINUE 
c 
c     * Check      of Convergence of Integrands * 
c 
        sI11=cdabs((QZA(2)+4.d0*QZB(2)+QZB(2)))/3.d0
        sI12=cdabs((WZA(2)+4.d0*WZB(2)+WZB(2)))/3.d0
        if(sI11.ge.sImax1)sImax1=sI11 
        if(sI12.ge.sImax2)sImax2=sI12 
c      write(2,999)k,si11,simax1,si11/simax1,si12,simax2,si12/simax2 
        if(((sI11/sImax1).lt.0.0001d0).and. 
     *                       ((sI12/sImax2).lt.0.0001d0))then 
c          write(*,*)' Simpson Range 2: k*R & Int.Num.=',WC*RR,K 
c          write(*,*)'sI11,sI12',sI11,sI12 
c          write(*,*)'sImax1,sImax2',sImax1,sImax2 
c          write(*,*)'sI11/sImax1 < 0.0001d !!: sI11/sImax1=',sI11/sImax1 
c          write(*,*)'sI12/sImax2 < 0.0001d !!: sI12/sImax2=',sI12/sImax2 
          goto 10 
        end if 
c 
        IF(RR*WC.GT.8.D0)THEN 
          NRNG=2 
          IRNG=I 
          IF(I.EQ.N12)THEN 
            NRNG=3 
            IRNG=0 
          END IF 
          RETURN 
        END IF 
 
  200 CONTINUE 
C 
   10 NRNG=3 
c        
      RETURN 
      END 
C 
C 
C *** THE INTEGRANDS OF Q, V, AND W AND THEIR DERIVATIVES for Simpson's *** 
C 
      SUBROUTINE INTEGS0(OM,K,WN,QX,QZ,VX,WX,WZ) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 QX(0:2),QZ(0:2),VX(0:2),WX(0:2),WZ(0:2) 
     *   ,VLX(2),URX(2,2),URZ(2,2),VLX0(2),URX0(2,2),URZ0(2,2) 
     *   ,VLXZ,URXZ(2),URZZ(2),SM,RAM,OM 
      DIMENSION BJ0(0:1),BJ1(0:1),BJK(0:1),BJD(0:1) 
      COMMON /FREQ/DOM,IOM,NOM,OMI
     *       /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                    ,VS(20),QS(20),FS(20),THK(20),NL 
     *       /OTST/IOT,IST /FCQVW/SM,RAM,RR 
C 
C   * CHECK OF DIMENSION * 
C 
      NC=20 
      IF(NL.GE.NC)THEN 
        WRITE(10,*)' FROM INTEGS:NL>NC !!!!!!!!!!' 
        WRITE(10,*)' NL,NC=',NL,NC 
        STOP 
      END IF 
C 
c   * the displacement-stress vectors * 
c 
      if(IST.eq.0)then 
        CALL RTSH(OM,K,WN,VLX) 
        CALL RTPSV(OM,K,WN,URX,URZ) 
        CALL RTSH0(dcmplx(0.d0,OMI),K,WN,VLX0) 
        CALL RTPSV0(dcmplx(0.d0,OMI),K,WN,URX0,URZ0) 
        VLX(1)=VLX(1)-VLX0(1) 
        URX(1,1)=URX(1,1)-URX0(1,1) 
        URX(2,1)=URX(2,1)-URX0(2,1) 
        URZ(1,1)=URZ(1,1)-URZ0(1,1) 
        URZ(2,1)=URZ(2,1)-URZ0(2,1) 
        VLX(2)=VLX(2)-VLX0(2) 
        URX(1,2)=URX(1,2)-URX0(1,2) 
        URX(2,2)=URX(2,2)-URX0(2,2) 
        URZ(1,2)=URZ(1,2)-URZ0(1,2) 
        URZ(2,2)=URZ(2,2)-URZ0(2,2) 
      else 
        if(IST.eq.1)then 
          CALL RTSH(OM,K,WN,VLX) 
          CALL RTPSV(OM,K,WN,URX,URZ) 
        else 
          if(IST.eq.2)then 
            CALL RTSH0(dcmplx(0.d0,OMI),K,WN,VLX) 
            CALL RTPSV0(dcmplx(0.d0,OMI),K,WN,URX,URZ) 
c            CALL RTSHc(dcmplx(0.d0,OMI),dcmplx(WN,0.d0),VLX) 
c            CALL RTPSVc(dcmplx(0.d0,OMI),dcmplx(WN,0.d0),URX,URZ) 
          end if 
        end if 
      end if 
C 
c      write(*,*)'k,wn',k,wn 
c      write(*,*)'vlx(1)',vlx(1) 
c      write(*,*)'vlx(2)',vlx(2) 
c      write(*,*)'URX(2,1)',URX(2,1) 
c      write(*,*)'URX(2,2)',URX(2,2) 
c      write(*,*)'vlx(1)',vlx(1) 
c      write(*,*)'vlx(2)',vlx(2) 
c      write(*,*)'URX(2,1)',URX(2,1) 
c      write(*,*)'URX(2,2)',URX(2,2) 
c      stop 
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.d0*SM)
      URZZ(2)=(URZ(2,2)-WN*RAM*URZ(1,1))/(RAM+2.d0*SM)
C 
c   * the Bessel functions * 
c 
      RK=WN*RR 
      call bj01(RK,BJ0(0),BJ1(0)) 
c      BJ0(0)=BSJ0(RK) 
c      BJ1(0)=BSJ1(RK) 
      IF(RK.EQ.0.0)THEN 
        BJK(0)=0.5d0
      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.d0
      ELSE 
        BJK(1)=(BJ1(1)-BJ1(0)/RR)/RK 
      END IF 
      BJD(1)= BJ0(1)-BJK(1) 
C 
c   * the integrands * 
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 
      IF(IOT.eq.1)THEN 
        WRITE(30,1100)RK,QX(0),VX(0),WX(0),QZ(0),WZ(0) 
     *                        ,QX(1),VX(1),WX(1),QZ(1),WZ(1) 
     *                        ,QX(2),VX(2),WX(2),QZ(2),WZ(2) 
      END IF 
 1100 FORMAT(31E12.4) 
C 
      RETURN 
      END 
C 
C 
C *** THE COMPUTATION OF Q, V, AND W AND THEIR DERIVATIVES  
C     USING Filon'S INTEGRATION FORMULA (after k*r > 8.0) *** 
C 
      SUBROUTINE QVWRZF0(OM,GQX,GQZ,GVX,GWX,GWZ) 
C      
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 GQX(0:2),GQZ(0:2),GVX(0:2),GWX(0:2),GWZ(0:2) 
     *      ,QXSA(0:2),QZSA(0:2),VXSA(0:2),WXSA(0:2),WZSA(0:2) 
     *      ,QXCA(0:2),QZCA(0:2),VXCA(0:2),WXCA(0:2),WZCA(0:2) 
     *      ,QXSB(0:2),QZSB(0:2),VXSB(0:2),WXSB(0:2),WZSB(0:2) 
     *      ,QXCB(0:2),QZCB(0:2),VXCB(0:2),WXCB(0:2),WZCB(0:2) 
     *      ,QXSC(0:2),QZSC(0:2),VXSC(0:2),WXSC(0:2),WZSC(0:2) 
     *      ,QXCC(0:2),QZCC(0:2),VXCC(0:2),WXCC(0:2),WZCC(0:2) 
     *      ,QXS1(0:2),QZS1(0:2),VXS1(0:2),WXS1(0:2),WZS1(0:2) 
     *      ,QXC1(0:2),QZC1(0:2),VXC1(0:2),WXC1(0:2),WZC1(0:2) 
     *      ,SM,RAM,S1,S2,OM 
      COMMON /FCQVW/SM,RAM,RR  /IRANGE/NRNG,IRNG 
     *       /INTG/VPMAX,VSMAX,RYMIN,CFINAL,N11,N12,M11 
     *       /WVNUM/WVN(2001),DWN,WNR(3),NWN 
     *             /sInteg/sImax1,sImax2 
C 
C *** Dimesion Check *** 
C 
      NC=2001 
      IF(NWN.GT.NC)THEN 
         WRITE(10,*)' FROM QVWRZF: NWN.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C   * RANGE 1 : From near Zero to near om/Rayleigh(min) * 
C 
c      write(2,*) 
c 
      IF(NRNG.EQ.3)RETURN 
 
      JRNG=0 
      IF(NRNG.GT.1)GOTO 10 
C 
      K=2*IRNG+1 
      WA=WVN(K) 
c      write(*,*)'QVWRZF(Range 1):WA*RR',WA*RR 
      CALL INTEGF0(OM,K,WA,QXSA,QZSA,VXSA,WXSA,WZSA 
     *                    ,QXCA,QZCA,VXCA,WXCA,WZCA) 
c 
      DO  300 I=IRNG+1,M11 
c 
        K=2*I 
        WB=WVN(K) 
        CALL INTEGF0(OM,K,WB,QXSB,QZSB,VXSB,WXSB,WZSB 
     *                      ,QXCB,QZCB,VXCB,WXCB,WZCB) 
        K=K+1 
        WC=WVN(K) 
        CALL INTEGF0(OM,K,WC,QXSC,QZSC,VXSC,WXSC,WZSC 
     *                      ,QXCC,QZCC,VXCC,WXCC,WZCC) 
c 
        H=WC-WB 
        th=RR*H 
        t=1.d0/th 
        t2=t*t 
        t3=t2*t 
        si=dsin(th) 
        ss=si*si 
        ci=dcos(th) 
        cc=ci*ci 
        si2=dsin(2.d0*th)
c 
        a1=t+0.5d0*si2*t2-2.d0*ss*t3
        b1=2.d0*((1.d0+cc)*t2-si2*t3)
        c1=4.d0*(si*t3-ci*t2) 
c 
        SA=1.D0/DTAN(RR*WA) 
        CA=DTAN(RR*WA) 
        SC=1.D0/DTAN(RR*WC) 
        CC=DTAN(RR*WC) 
        DO 350 J=0,2 
          QXS1(J)=(QXSA(J)+QXSC(J))*0.5d0 
          QZS1(J)=(QZSA(J)+QZSC(J))*0.5d0 
          VXS1(J)=(VXSA(J)+VXSC(J))*0.5d0 
          WXS1(J)=(WXSA(J)+WXSC(J))*0.5d0 
          WZS1(J)=(WZSA(J)+WZSC(J))*0.5d0 
          QXC1(J)=(QXCA(J)+QXCC(J))*0.5d0 
          QZC1(J)=(QZCA(J)+QZCC(J))*0.5d0 
          VXC1(J)=(VXCA(J)+VXCC(J))*0.5d0 
          WXC1(J)=(WXCA(J)+WXCC(J))*0.5d0 
          WZC1(J)=(WZCA(J)+WZCC(J))*0.5d0 
c 
          S1=A1*(QXSA(J)*SA-QXSC(J)*SC)+B1*QXS1(J)+C1*QXSB(J) 
          S2=A1*(QXCC(J)*CC-QXCA(J)*CA)+B1*QXC1(J)+C1*QXCB(J) 
          GQX(J)=GQX(J)+H*(S1+S2) 
          S1=A1*(QZSA(J)*SA-QZSC(J)*SC)+B1*QZS1(J)+C1*QZSB(J) 
          S2=A1*(QZCC(J)*CC-QZCA(J)*CA)+B1*QZC1(J)+C1*QZCB(J) 
          GQZ(J)=GQZ(J)+H*(S1+S2) 
          S1=A1*(VXSA(J)*SA-VXSC(J)*SC)+B1*VXS1(J)+C1*VXSB(J) 
          S2=A1*(VXCC(J)*CC-VXCA(J)*CA)+B1*VXC1(J)+C1*VXCB(J) 
          GVX(J)=GVX(J)+H*(S1+S2) 
          S1=A1*(WXSA(J)*SA-WXSC(J)*SC)+B1*WXS1(J)+C1*WXSB(J) 
          S2=A1*(WXCC(J)*CC-WXCA(J)*CA)+B1*WXC1(J)+C1*WXCB(J) 
          GWX(J)=GWX(J)+H*(S1+S2) 
          S1=A1*(WZSA(J)*SA-WZSC(J)*SC)+B1*WZS1(J)+C1*WZSB(J) 
          S2=A1*(WZCC(J)*CC-WZCA(J)*CA)+B1*WZC1(J)+C1*WZCB(J) 
          GWZ(J)=GWZ(J)+H*(S1+S2) 
c 
          QXSA(J)=QXSC(J) 
          QZSA(J)=QZSC(J) 
          VXSA(J)=VXSC(J) 
          WXSA(J)=WXSC(J) 
          WZSA(J)=WZSC(J) 
          QXCA(J)=QXCC(J) 
          QZCA(J)=QZCC(J) 
          VXCA(J)=VXCC(J) 
          WXCA(J)=WXCC(J) 
          WZCA(J)=WZCC(J) 
c 
          WA=WC 
  350   CONTINUE 
c 
c     * Check      of Convergence of Integrands * 
c 
        S1=A1*(QZSA(2)*SA-QZSC(2)*SC)+B1*QZS1(2)+C1*QZSB(2) 
        S2=A1*(QZCC(2)*CC-QZCA(2)*CA)+B1*QZC1(2)+C1*QZCB(2) 
        sI11=cdabs(S1+S2) 
        S1=A1*(WZSA(2)*SA-WZSC(2)*SC)+B1*WZS1(2)+C1*WZSB(2) 
        S2=A1*(WZCC(2)*CC-WZCA(2)*CA)+B1*WZC1(2)+C1*WZCB(2) 
        sI12=cdabs(S1+S2) 
        if(sI11.ge.sImax1)sImax1=sI11 
        if(sI12.ge.sImax2)sImax2=sI12 
c      write(2,999)k,si11,simax1,si11/simax1,si12,simax2,si12/simax2 
c 999  format(i5,6e12.4) 
        if(((sI11/sImax1).lt.0.00001d0).and. 
     *                       ((sI12/sImax2).lt.0.00001d0))then 
c          write(*,*)' Filon Range 1: k*R & Int.Num.=',WC*RR,K 
c          write(*,*)'sI11,sI12',sI11,sI12 
c          write(*,*)'sImax1,sImax2',sImax1,sImax2 
c          write(*,*)'sI11/sImax1 < 0.00001d !: sI11/sImax1=',sI11/sImax1 
c          write(*,*)'sI12/sImax2 < 0.00001d !: sI12/sImax2=',sI12/sImax2 
          goto 20 
        end if 
c 
  300 CONTINUE 
 
c      write(*,*)'f1:gqx0',gqx(0) 
C 
C   * RANGE 2 : From om/Rayleigh(min) to om/C(final) * 
C 
      JRNG=1 
      IRNG=0 
C 
   10 H=DWN 
      th=RR*H 
      t=1.d0/th 
      t2=t*t 
      t3=t2*t 
      si=dsin(th) 
      ss=si*si 
      ci=dcos(th) 
      cc=ci*ci 
      si2=dsin(2.d0*th)
      a1=t+0.5d0*si2*t2-2.d0*ss*t3
      b1=2.d0*((1.d0+cc)*t2-si2*t3)
      c1=4.d0*(si*t3-ci*t2) 
c 
      K=2*(M11+IRNG)+1 
      WA=WVN(K) 
c      write(*,*)'QVWRZF(Range 2):WA*RR',WA*RR 
      IF(JRNG.EQ.1)GOTO 15 
      CALL INTEGF0(OM,K,WA,QXSA,QZSA,VXSA,WXSA,WZSA 
     *                    ,QXCA,QZCA,VXCA,WXCA,WZCA) 
c 
   15 DO  400 I=IRNG+1,N12 
        K=2*(M11+I) 
        WB=WVN(K) 
        CALL INTEGF0(OM,K,WB,QXSB,QZSB,VXSB,WXSB,WZSB 
     *                      ,QXCB,QZCB,VXCB,WXCB,WZCB) 
        K=K+1 
        WC=WVN(K) 
        CALL INTEGF0(OM,K,WC,QXSC,QZSC,VXSC,WXSC,WZSC 
     *                      ,QXCC,QZCC,VXCC,WXCC,WZCC) 
c 
        SA=1.D0/DTAN(RR*WA) 
        CA=DTAN(RR*WA) 
        SC=1.D0/DTAN(RR*WC) 
        CC=DTAN(RR*WC) 
        DO 450 J=0,2 
          QXS1(J)=(QXSA(J)+QXSC(J))*0.5d0 
          QZS1(J)=(QZSA(J)+QZSC(J))*0.5d0 
          VXS1(J)=(VXSA(J)+VXSC(J))*0.5d0 
          WXS1(J)=(WXSA(J)+WXSC(J))*0.5d0 
          WZS1(J)=(WZSA(J)+WZSC(J))*0.5d0 
          QXC1(J)=(QXCA(J)+QXCC(J))*0.5d0 
          QZC1(J)=(QZCA(J)+QZCC(J))*0.5d0 
          VXC1(J)=(VXCA(J)+VXCC(J))*0.5d0 
          WXC1(J)=(WXCA(J)+WXCC(J))*0.5d0 
          WZC1(J)=(WZCA(J)+WZCC(J))*0.5d0 
c 
          S1=A1*(QXSA(J)*SA-QXSC(J)*SC)+B1*QXS1(J)+C1*QXSB(J) 
          S2=A1*(QXCC(J)*CC-QXCA(J)*CA)+B1*QXC1(J)+C1*QXCB(J) 
          GQX(J)=GQX(J)+H*(S1+S2) 
          S1=A1*(QZSA(J)*SA-QZSC(J)*SC)+B1*QZS1(J)+C1*QZSB(J) 
          S2=A1*(QZCC(J)*CC-QZCA(J)*CA)+B1*QZC1(J)+C1*QZCB(J) 
          GQZ(J)=GQZ(J)+H*(S1+S2) 
          S1=A1*(VXSA(J)*SA-VXSC(J)*SC)+B1*VXS1(J)+C1*VXSB(J) 
          S2=A1*(VXCC(J)*CC-VXCA(J)*CA)+B1*VXC1(J)+C1*VXCB(J) 
          GVX(J)=GVX(J)+H*(S1+S2) 
          S1=A1*(WXSA(J)*SA-WXSC(J)*SC)+B1*WXS1(J)+C1*WXSB(J) 
          S2=A1*(WXCC(J)*CC-WXCA(J)*CA)+B1*WXC1(J)+C1*WXCB(J) 
          GWX(J)=GWX(J)+H*(S1+S2) 
          S1=A1*(WZSA(J)*SA-WZSC(J)*SC)+B1*WZS1(J)+C1*WZSB(J) 
          S2=A1*(WZCC(J)*CC-WZCA(J)*CA)+B1*WZC1(J)+C1*WZCB(J) 
          GWZ(J)=GWZ(J)+H*(S1+S2) 
c 
          QXSA(J)=QXSC(J) 
          QZSA(J)=QZSC(J) 
          VXSA(J)=VXSC(J) 
          WXSA(J)=WXSC(J) 
          WZSA(J)=WZSC(J) 
          QXCA(J)=QXCC(J) 
          QZCA(J)=QZCC(J) 
          VXCA(J)=VXCC(J) 
          WXCA(J)=WXCC(J) 
          WZCA(J)=WZCC(J) 
c 
          WA=WC 
  450   CONTINUE 
c 
c     * Check      of Convergence of Integrands * 
c 
        S1=A1*(QZSA(2)*SA-QZSC(2)*SC)+B1*QZS1(2)+C1*QZSB(2) 
        S2=A1*(QZCC(2)*CC-QZCA(2)*CA)+B1*QZC1(2)+C1*QZCB(2) 
        sI11=cdabs(S1+S2) 
        S1=A1*(WZSA(2)*SA-WZSC(2)*SC)+B1*WZS1(2)+C1*WZSB(2) 
        S2=A1*(WZCC(2)*CC-WZCA(2)*CA)+B1*WZC1(2)+C1*WZCB(2) 
        sI12=cdabs(S1+S2) 
        if(sI11.ge.sImax1)sImax1=sI11 
        if(sI12.ge.sImax2)sImax2=sI12 
c      write(2,999)k,si11,simax1,si11/simax1,si12,simax2,si12/simax2 
        if(((sI11/sImax1).lt.0.00001d0).and. 
     *                       ((sI12/sImax2).lt.0.00001d0))then 
c          write(*,*)' Filon Range 2: k*R & Int.Num.=',WC*RR,K 
c          write(*,*)'sI11,sI12',sI11,sI12 
c          write(*,*)'sImax1,sImax2',sImax1,sImax2 
c          write(*,*)'sI11/sImax1 < 0.00001d !: sI11/sImax1=',sI11/sImax1 
c          write(*,*)'sI12/sImax2 < 0.00001d !: sI12/sImax2=',sI12/sImax2 
          goto 20 
        end if 
c 
  400 CONTINUE 
 
c      write(*,*)'f2:gqx0',gqx(0) 
c 
   20 RETURN 
      END 
C 
C 
C *** THE INTEGRANDS OF Q, V, AND W AND THEIR DERIVATIVES for Filon's *** 
C 
      SUBROUTINE INTEGF0(OM,K,WN,QXS,QZS,VXS,WXS,WZS 
     *                          ,QXC,QZC,VXC,WXC,WZC) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 QXS(0:2),QZS(0:2),VXS(0:2),WXS(0:2),WZS(0:2) 
     *   ,QXC(0:2),QZC(0:2),VXC(0:2),WXC(0:2),WZC(0:2) 
     *   ,VLX(2),URX(2,2),URZ(2,2),VLX0(2),URX0(2,2),URZ0(2,2) 
     *   ,VLXZ,URXZ(2),URZZ(2),SM,RAM,OM 
      DIMENSION BJ0S(0:1),BJ1S(0:1),BJKS(0:1),BJDS(0:1) 
     *         ,BJ0C(0:1),BJ1C(0:1),BJKC(0:1),BJDC(0:1) 
      COMMON /FREQ/DOM,IOM,NOM,OMI
     *       /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                    ,VS(20),QS(20),FS(20),THK(20),NL 
     *       /OTST/IOT,IST /FCQVW/SM,RAM,RR 
C 
C *** CHECK OF DIMENSION *** 
C 
      NC=20 
      IF(NL.GE.NC)THEN 
        WRITE(10,*)' FROM INTEGF:NL>NC !!!!!!!!!!' 
        WRITE(10,*)' NL,NC=',NL,NC 
        STOP 
      END IF 
C 
c   * the displacement-stress vectors * 
c 
      if(IST.eq.0)then 
        CALL RTSH(OM,K,WN,VLX) 
        CALL RTPSV(OM,K,WN,URX,URZ) 
        CALL RTSH0(dcmplx(0.d0,OMI),K,WN,VLX0) 
        CALL RTPSV0(dcmplx(0.d0,OMI),K,WN,URX0,URZ0) 
        VLX(1)=VLX(1)-VLX0(1) 
        URX(1,1)=URX(1,1)-URX0(1,1) 
        URX(2,1)=URX(2,1)-URX0(2,1) 
        URZ(1,1)=URZ(1,1)-URZ0(1,1) 
        URZ(2,1)=URZ(2,1)-URZ0(2,1) 
        VLX(2)=VLX(2)-VLX0(2) 
        URX(1,2)=URX(1,2)-URX0(1,2) 
        URX(2,2)=URX(2,2)-URX0(2,2) 
        URZ(1,2)=URZ(1,2)-URZ0(1,2) 
        URZ(2,2)=URZ(2,2)-URZ0(2,2) 
      else 
        if(IST.eq.1)then 
          CALL RTSH(OM,K,WN,VLX) 
          CALL RTPSV(OM,K,WN,URX,URZ) 
        else 
          if(IST.eq.2)then 
            CALL RTSH0(dcmplx(0.d0,OMI),K,WN,VLX) 
            CALL RTPSV0(dcmplx(0.d0,OMI),K,WN,URX,URZ) 
          end if 
        end if 
      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.d0*SM)
      URZZ(2)=(URZ(2,2)-WN*RAM*URZ(1,1))/(RAM+2.d0*SM)
C 
c   * SIN and COS parts of the approximate Bessel functions * 
c 
      PI=4.D0*DATAN(1.D0) 
      RK=WN*RR 
      A=1.D0/DSQRT(PI*RK) 
      SRK=A*DSIN(RK) 
      CRK=A*DCOS(RK) 
c 
      x1=0.125d0/rk 
      x2=0.0703125d0/(rk*rk) 
      x3=0.073242188d0/(rk*rk*rk)       
      BJ0S(0)= SRK*(1.D0+x1-x2-x3) 
      BJ0C(0)= CRK*(1.D0-x1-x2+x3) 
 
      y1=0.375d0/rk 
      y2=0.1171875d0/(rk*rk) 
      y3=0.102539063d0/(rk*rk*rk) 
      BJ1S(0)= SRK*(1.D0+y1+y2-y3) 
      BJ1C(0)=-CRK*(1.D0-y1+y2+y3) 
C 
      BJKS(0)=BJ1S(0)/RK 
      BJKC(0)=BJ1C(0)/RK 
      BJDS(0)=BJ0S(0)-BJKS(0) 
      BJDC(0)=BJ0C(0)-BJKC(0) 
C 
      BJ0S(1)=-BJ1S(0)*WN 
      BJ0C(1)=-BJ1C(0)*WN 
      BJ1S(1)= BJDS(0)*WN 
      BJ1C(1)= BJDC(0)*WN 
 
      BJKS(1)=(BJ1S(1)-BJ1S(0)/RR)/RK 
      BJKC(1)=(BJ1C(1)-BJ1C(0)/RR)/RK 
      BJDS(1)= BJ0S(1)-BJKS(1) 
      BJDC(1)= BJ0C(1)-BJKC(1) 
C 
c   * the integrands * 
c 
      QXS(0)= URX(1,1)*BJDS(0)+VLX(1)*BJKS(0) 
      QXC(0)= URX(1,1)*BJDC(0)+VLX(1)*BJKC(0) 
      VXS(0)= URX(1,1)*BJKS(0)+VLX(1)*BJDS(0) 
      VXC(0)= URX(1,1)*BJKC(0)+VLX(1)*BJDC(0) 
      WXS(0)= URX(2,1)*BJ1S(0) 
      WXC(0)= URX(2,1)*BJ1C(0) 
      QZS(0)= URZ(1,1)*BJ1S(0) 
      QZC(0)= URZ(1,1)*BJ1C(0) 
      WZS(0)= URZ(2,1)*BJ0S(0) 
      WZC(0)= URZ(2,1)*BJ0C(0) 
C 
      QXS(1)= URX(1,1)*BJDS(1)+VLX(1)*BJKS(1) 
      QXC(1)= URX(1,1)*BJDC(1)+VLX(1)*BJKC(1) 
      VXS(1)= URX(1,1)*BJKS(1)+VLX(1)*BJDS(1) 
      VXC(1)= URX(1,1)*BJKC(1)+VLX(1)*BJDC(1) 
      WXS(1)= URX(2,1)*BJ1S(1) 
      WXC(1)= URX(2,1)*BJ1C(1) 
      QZS(1)= URZ(1,1)*BJ1S(1) 
      QZC(1)= URZ(1,1)*BJ1C(1) 
      WZS(1)= URZ(2,1)*BJ0S(1) 
      WZC(1)= URZ(2,1)*BJ0C(1) 
C 
      QXS(2)= URXZ(1)*BJDS(0)+VLXZ*BJKS(0) 
      QXC(2)= URXZ(1)*BJDC(0)+VLXZ*BJKC(0) 
      VXS(2)= URXZ(1)*BJKS(0)+VLXZ*BJDS(0) 
      VXC(2)= URXZ(1)*BJKC(0)+VLXZ*BJDC(0) 
      WXS(2)= URXZ(2)*BJ1S(0) 
      WXC(2)= URXZ(2)*BJ1C(0) 
      QZS(2)= URZZ(1)*BJ1S(0) 
      QZC(2)= URZZ(1)*BJ1C(0) 
      WZS(2)= URZZ(2)*BJ0S(0) 
      WZC(2)= URZZ(2)*BJ0C(0) 
C 
      IF(IOT.eq.1)THEN 
        WRITE(30,1100)RK,QXS(0)+QXC(0),VXS(0)+VXC(0),WXS(0)+WXC(0) 
     *    ,QZS(0)+QZC(0),WZS(0)+WZC(0),QXS(1)+QXC(1),VXS(1)+VXC(1) 
     *    ,WXS(1)+WXC(1),QZS(1)+QZC(1),WZS(1)+WZC(1),QXS(2)+QXC(2) 
     *    ,VXS(2)+VXC(2),WXS(2)+WXC(2),QZS(2)+QZC(2),WZS(2)+WZC(2) 
      END IF 
 1100 FORMAT(31E12.4) 
C 
      RETURN 
      END 
C 
C 
C 
C *** Library for SH UPGOING/DOWNGOING COEFFICIENTS *** 
C 
      SUBROUTINE CUDSH0(OM) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 VSc,CD,CU,VS2,WS2,CMS,SM,EE(2,2),DD,DU,WN,WN2,DQ
     *  ,CUSU,CDSU,CDSD,CUSD,GTD,GTU,GRD,GRU,AU,BU,AD,BD,CS,OM,OM2 
      COMMON /SOLY/SDEP,ODEP,LS,LO  
     *       /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                    ,VS(20),QS(20),FS(20),THK(20),NL 
     *       /DUSH0/CD(2001,20),CU(2001,20) 
     *       ,CUSU(2001),CDSU(2001),CDSD(2001),CUSD(2001)  
     *       /GRTSH/GTD(0:20),GTU(0:20),GRD(0:20),GRU(0:20) 
     *       /WVNUM/WVN(2001),DWN,WNR(3),NWN 
C 
C *** CHECK FOR THE DIMENSION OF CD, CU, AND GTD-GRU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM CUDSH: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
      NC=2001 
      IF(NWN.GT.NC)THEN 
         WRITE(10,*)' FROM CUDSH: NWN.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** DOWN/UP-R/T COEFFICIENTS FOR ALL LAYERS AT ALL WAVE-NUMBERS *** 
C 
      OM2=OM*OM 
      QSe=FuncQS(OM,LS)
      VSc=VS(LS)*DCMPLX(1.D0,-0.5D0/QSe) 
      VS2=VSc*VSc 
      WS2=OM2/VS2 
      SM=DNS(LS)*VS2 
      EE(1,1)=(1.d0,0.d0)
      EE(1,2)=(1.d0,0.d0)
C 
      DO 100 I=1,NWN 
C 
        WN=dcmplx(WVN(I),0.d0) 
C 
C     * COMPUTATION OF GENERALIZED R/T MATRICES * 
C 
        CALL GNRTSHc(OM,WN) 
C 
C     * COMPUTATION OF  CD AND CU * 
C 
        WN2=WN*WN 
        CMS=CDSQRT(WN2-WS2) 
        IF(dREAL(CMS).LT.0.0)CMS=-CMS 
C 
        EE(2,1)=-SM*CMS 
        EE(2,2)= SM*CMS 
C 
        DQ=-WN/6.2831853072d0 
C 
        IF((LS.EQ.1).AND.(SDEP.EQ.0.d0))THEN
C 
          IF(NL.EQ.1)THEN 
            CDSD(I)=DQ/EE(2,1) 
            CUSD(I)=(0.d0,0.d0)
          ELSE 
            DD=CDEXP(-CMS*THK(1)) 
            CDSD(I)=DQ/(EE(2,1)+EE(2,2)*DD*GRD(1)) 
            CUSD(I)=GRD(1)*CDSD(I) 
          END IF 
C 
        ELSE 
C  
          IF(LS.EQ.NL)THEN  
C 
            DD=CDEXP(-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)=DQ/(BD*CS-BU) 
            CDSU(I)=GRU(LS-1)*CUSU(I) 
            CDSD(I)=CS*CUSU(I) 
C 
          ELSE 
C 
            DD=CDEXP(-CMS*SDEP) 
            DU=CDEXP(-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)=DQ/(BD*CS-BU) 
            CDSU(I)=GRU(LS-1)*CUSU(I) 
            CDSD(I)=CS*CUSU(I) 
            CUSD(I)=GRD(LS)*CDSD(I) 
C 
          ENDIF 
C 
        END IF 
C 
        IF(LS.EQ.1)GOTO 10 
        CU(I,LS-1)=GTU(LS-1)*CUSU(I) 
        DO 110 J=LS-2,1,-1 
          CU(I,J)=GTU(J)*CU(I,J+1) 
          CD(I,J+1)=GRU(J)*CU(I,J+1) 
  110   CONTINUE 
        CD(I,1)=GRU(0)*CU(I,1) 
C 
   10   IF(LS.EQ.NL)GOTO 100 
        CD(I,LS+1)=GTD(LS)*CDSD(I) 
        DO 120 J=LS+1,NL-1 
          CD(I,J+1)=GTD(J)*CD(I,J) 
          CU(I,J)=GRD(J)*CD(I,J) 
  120   CONTINUE 
C 
  100 CONTINUE 
C 
      RETURN 
      END 
C 
C *** Library for SH UPGOING/DOWNGOING COEFFICIENTS *** 
C 
      SUBROUTINE CUDSH(OM) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 VSc,CD,CU,VS2,WS2,CMS,SM,EE(2,2),DD,DU,WN,WN2,DQ
     *  ,CUSU,CDSU,CDSD,CUSD,GTD,GTU,GRD,GRU,AU,BU,AD,BD,CS,OM,OM2 
      COMMON /SOLY/SDEP,ODEP,LS,LO  
     *       /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                    ,VS(20),QS(20),FS(20),THK(20),NL 
     *       /DUSH/CD(2001,20),CU(2001,20) 
     *       ,CUSU(2001),CDSU(2001),CDSD(2001),CUSD(2001)  
     *       /GRTSH/GTD(0:20),GTU(0:20),GRD(0:20),GRU(0:20) 
     *       /WVNUM/WVN(2001),DWN,WNR(3),NWN 
C 
C *** CHECK FOR THE DIMENSION OF CD, CU, AND GTD-GRU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM CUDSH: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
      NC=2001 
      IF(NWN.GT.NC)THEN 
         WRITE(10,*)' FROM CUDSH: NWN.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** DOWN/UP-R/T COEFFICIENTS FOR ALL LAYERS AT ALL WAVE-NUMBERS *** 
C 
      OM2=OM*OM 
      QSe=FuncQS(OM,LS)
      VSc=VS(LS)*DCMPLX(1.D0,-0.5D0/QSe) 
      VS2=VSc*VSc 
      WS2=OM2/VS2 
      SM=DNS(LS)*VS2 
      EE(1,1)=(1.d0,0.d0)
      EE(1,2)=(1.d0,0.d0)
C 
      DO 100 I=1,NWN 
C 
        WN=dcmplx(WVN(I),0.d0) 
C 
C     * COMPUTATION OF GENERALIZED R/T MATRICES * 
C 
        CALL GNRTSHc(OM,WN) 
C 
C     * COMPUTATION OF  CD AND CU * 
C 
        WN2=WN*WN 
        CMS=CDSQRT(WN2-WS2) 
        IF(dREAL(CMS).LT.0.0)CMS=-CMS 
C 
        EE(2,1)=-SM*CMS 
        EE(2,2)= SM*CMS 
C 
        DQ=-WN/6.2831853072d0 
C 
        IF((LS.EQ.1).AND.(SDEP.EQ.0.d0))THEN
C 
          IF(NL.EQ.1)THEN 
            CDSD(I)=DQ/EE(2,1) 
            CUSD(I)=(0.d0,0.d0)
          ELSE 
            DD=CDEXP(-CMS*THK(1)) 
            CDSD(I)=DQ/(EE(2,1)+EE(2,2)*DD*GRD(1)) 
            CUSD(I)=GRD(1)*CDSD(I) 
          END IF 
C 
        ELSE 
C  
          IF(LS.EQ.NL)THEN  
C 
            DD=CDEXP(-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)=DQ/(BD*CS-BU) 
            CDSU(I)=GRU(LS-1)*CUSU(I) 
            CDSD(I)=CS*CUSU(I) 
C 
          ELSE 
C 
            DD=CDEXP(-CMS*SDEP) 
            DU=CDEXP(-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)=DQ/(BD*CS-BU) 
            CDSU(I)=GRU(LS-1)*CUSU(I) 
            CDSD(I)=CS*CUSU(I) 
            CUSD(I)=GRD(LS)*CDSD(I) 
C 
          ENDIF 
C 
        END IF 
C 
        IF(LS.EQ.1)GOTO 10 
        CU(I,LS-1)=GTU(LS-1)*CUSU(I) 
        DO 110 J=LS-2,1,-1 
          CU(I,J)=GTU(J)*CU(I,J+1) 
          CD(I,J+1)=GRU(J)*CU(I,J+1) 
  110   CONTINUE 
        CD(I,1)=GRU(0)*CU(I,1) 
C 
   10   IF(LS.EQ.NL)GOTO 100 
        CD(I,LS+1)=GTD(LS)*CDSD(I) 
        DO 120 J=LS+1,NL-1 
          CD(I,J+1)=GTD(J)*CD(I,J) 
          CU(I,J)=GRD(J)*CD(I,J) 
  120   CONTINUE 
C 
  100 CONTINUE 
C 
      RETURN 
      END 
C 
C 
C *** Library for P-SV UPGOING/DOWNGOING COEFFICIENTS *** 
C 
      SUBROUTINE CUDPSV0(OM) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 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,OM,WN,DQX,DQZ 
     *    ,AU(2,2),BU(2,2),AD(2,2),BD(2,2),CS(2,2),E1(2,2),E2(2,2) 
      COMMON /SOLY/SDEP,ODEP,LS,LO  
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     *  /DUPSVX0/CDX(2001,2,20),CUX(2001,2,20),CUSUX(2001,2) 
     *         ,CDSUX(2001,2),CDSDX(2001,2),CUSDX(2001,2)  
     *  /DUPSVZ0/CDZ(2001,2,20),CUZ(2001,2,20),CUSUZ(2001,2) 
     *         ,CDSUZ(2001,2),CDSDZ(2001,2),CUSDZ(2001,2)  
     *  /GRTPSV/GTD(2,2,0:20),GTU(2,2,0:20),GRD(2,2,0:20),GRU(2,2,0:20) 
     *  /WVNUM/WVN(2001),DWN,WNR(3),NWN 
C 
C *** CHECK FOR THE DIMENSION OF CD, CU, AND GTD-GRU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM CUDPSV: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
      NC=2001 
      IF(NWN.GT.NC)THEN 
         WRITE(10,*)' FROM CUDPSV: NWN.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** COMPUTATION OF GENERALIZED R/T MATRICES *** 
C 
      DO 100 K=1,NWN 
C 
        WN=dcmplx(WVN(K),0.d0) 
        CALL GNRTPSVc(OM,WN) 
C 
C *** COMPUTATION OF CD AND CU *** 
C 
        CALL MTXPSVc(OM,WN,LS,CMS,CMP,EE) 
C 
        DQX=-WN/6.2831853072d0 
        DQZ= WN/6.2831853072d0 
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)=E2(1,1)*DQX 
            CDSDX(K,2)=E2(2,1)*DQX 
            CUSDX(K,1)=(0.d0,0.d0)
            CUSDX(K,2)=(0.d0,0.d0)
            CDSDZ(K,1)=E2(1,2)*DQZ 
            CDSDZ(K,2)=E2(2,2)*DQZ 
            CUSDZ(K,1)=(0.d0,0.d0)
            CUSDZ(K,2)=(0.d0,0.d0)
C 
          ELSE 
C 
            CALL DDUPSVc(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)=E2(1,1)*DQX 
            CDSDX(K,2)=E2(2,1)*DQX 
            CUSDX(K,1)=GRD(1,1,1)*CDSDX(K,1) 
     *                  +GRD(1,2,1)*CDSDX(K,2) 
            CUSDX(K,2)=GRD(2,1,1)*CDSDX(K,1) 
     *                  +GRD(2,2,1)*CDSDX(K,2) 
            CDSDZ(K,1)=E2(1,2)*DQZ 
            CDSDZ(K,2)=E2(2,2)*DQZ 
            CUSDZ(K,1)=GRD(1,1,1)*CDSDZ(K,1) 
     *                  +GRD(1,2,1)*CDSDZ(K,2) 
            CUSDZ(K,2)=GRD(2,1,1)*CDSDZ(K,1) 
     *                  +GRD(2,2,1)*CDSDZ(K,2) 
C 
          END IF 
C  
        ELSE 
C 
          IF(LS.EQ.NL)THEN  
C 
            CALL DDUPSVc(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)=E2(1,1)*DQX 
            CUSUX(K,2)=E2(2,1)*DQX 
            CDSUX(K,1)=GRU(1,1,LS-1)*CUSUX(K,1) 
     *                +GRU(1,2,LS-1)*CUSUX(K,2) 
            CDSUX(K,2)=GRU(2,1,LS-1)*CUSUX(K,1) 
     *                +GRU(2,2,LS-1)*CUSUX(K,2) 
            CDSDX(K,1)=CS(1,1)*CUSUX(K,1)+CS(1,2)*CUSUX(K,2) 
            CDSDX(K,2)=CS(2,1)*CUSUX(K,1)+CS(2,2)*CUSUX(K,2) 
C 
            CUSUZ(K,1)=E2(1,2)*DQZ 
            CUSUZ(K,2)=E2(2,2)*DQZ 
            CDSUZ(K,1)=GRU(1,1,LS-1)*CUSUZ(K,1) 
     *                +GRU(1,2,LS-1)*CUSUZ(K,2) 
            CDSUZ(K,2)=GRU(2,1,LS-1)*CUSUZ(K,1) 
     *                +GRU(2,2,LS-1)*CUSUZ(K,2) 
            CDSDZ(K,1)=CS(1,1)*CUSUZ(K,1)+CS(1,2)*CUSUZ(K,2) 
            CDSDZ(K,2)=CS(2,1)*CUSUZ(K,1)+CS(2,2)*CUSUZ(K,2) 
C 
          ELSE 
C 
            CALL DDUPSVc(OM,WN,SDEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)=E2(1,1)*DQX 
            CUSUX(K,2)=E2(2,1)*DQX 
            CDSUX(K,1)=GRU(1,1,LS-1)*CUSUX(K,1) 
     *                +GRU(1,2,LS-1)*CUSUX(K,2) 
            CDSUX(K,2)=GRU(2,1,LS-1)*CUSUX(K,1) 
     *                +GRU(2,2,LS-1)*CUSUX(K,2) 
            CDSDX(K,1)=CS(1,1)*CUSUX(K,1)+CS(1,2)*CUSUX(K,2) 
            CDSDX(K,2)=CS(2,1)*CUSUX(K,1)+CS(2,2)*CUSUX(K,2) 
            CUSDX(K,1)=GRD(1,1,LS)*CDSDX(K,1) 
     *                +GRD(1,2,LS)*CDSDX(K,2) 
            CUSDX(K,2)=GRD(2,1,LS)*CDSDX(K,1) 
     *                +GRD(2,2,LS)*CDSDX(K,2) 
C 
            CUSUZ(K,1)=E2(1,2)*DQZ 
            CUSUZ(K,2)=E2(2,2)*DQZ 
            CDSUZ(K,1)=GRU(1,1,LS-1)*CUSUZ(K,1) 
     *                +GRU(1,2,LS-1)*CUSUZ(K,2) 
            CDSUZ(K,2)=GRU(2,1,LS-1)*CUSUZ(K,1) 
     *                +GRU(2,2,LS-1)*CUSUZ(K,2) 
            CDSDZ(K,1)=CS(1,1)*CUSUZ(K,1)+CS(1,2)*CUSUZ(K,2) 
            CDSDZ(K,2)=CS(2,1)*CUSUZ(K,1)+CS(2,2)*CUSUZ(K,2) 
            CUSDZ(K,1)=GRD(1,1,LS)*CDSDZ(K,1) 
     *                +GRD(1,2,LS)*CDSDZ(K,2) 
            CUSDZ(K,2)=GRD(2,1,LS)*CDSDZ(K,1) 
     *                +GRD(2,2,LS)*CDSDZ(K,2) 
C 
          ENDIF 
C 
        END IF 
C 
        IF(LS.EQ.1)GOTO 10 
          CUX(K,1,LS-1)=GTU(1,1,LS-1)*CUSUX(K,1) 
     *                 +GTU(1,2,LS-1)*CUSUX(K,2) 
          CUX(K,2,LS-1)=GTU(2,1,LS-1)*CUSUX(K,1) 
     *                 +GTU(2,2,LS-1)*CUSUX(K,2) 
          CUZ(K,1,LS-1)=GTU(1,1,LS-1)*CUSUZ(K,1) 
     *                 +GTU(1,2,LS-1)*CUSUZ(K,2) 
          CUZ(K,2,LS-1)=GTU(2,1,LS-1)*CUSUZ(K,1) 
     *                 +GTU(2,2,LS-1)*CUSUZ(K,2) 
        DO 110 I=LS-2,1,-1 
          CUX(K,1,I)  =GTU(1,1,I)*CUX(K,1,I+1) 
     *                +GTU(1,2,I)*CUX(K,2,I+1) 
          CUX(K,2,I)  =GTU(2,1,I)*CUX(K,1,I+1) 
     *                +GTU(2,2,I)*CUX(K,2,I+1) 
          CDX(K,1,I+1)=GRU(1,1,I)*CUX(K,1,I+1) 
     *                +GRU(1,2,I)*CUX(K,2,I+1) 
          CDX(K,2,I+1)=GRU(2,1,I)*CUX(K,1,I+1) 
     *                +GRU(2,2,I)*CUX(K,2,I+1) 
          CUZ(K,1,I)  =GTU(1,1,I)*CUZ(K,1,I+1) 
     *                +GTU(1,2,I)*CUZ(K,2,I+1) 
          CUZ(K,2,I)  =GTU(2,1,I)*CUZ(K,1,I+1) 
     *                +GTU(2,2,I)*CUZ(K,2,I+1) 
          CDZ(K,1,I+1)=GRU(1,1,I)*CUZ(K,1,I+1) 
     *                +GRU(1,2,I)*CUZ(K,2,I+1) 
          CDZ(K,2,I+1)=GRU(2,1,I)*CUZ(K,1,I+1) 
     *                +GRU(2,2,I)*CUZ(K,2,I+1) 
  110   CONTINUE 
        CDX(K,1,1)=GRU(1,1,0)*CUX(K,1,1)+GRU(1,2,0)*CUX(K,2,1) 
        CDX(K,2,1)=GRU(2,1,0)*CUX(K,1,1)+GRU(2,2,0)*CUX(K,2,1) 
        CDZ(K,1,1)=GRU(1,1,0)*CUZ(K,1,1)+GRU(1,2,0)*CUZ(K,2,1) 
        CDZ(K,2,1)=GRU(2,1,0)*CUZ(K,1,1)+GRU(2,2,0)*CUZ(K,2,1) 
C 
   10   IF(LS.EQ.NL)GOTO 100 
        CDX(K,1,LS+1)=GTD(1,1,LS)*CDSDX(K,1) 
     *               +GTD(1,2,LS)*CDSDX(K,2) 
        CDX(K,2,LS+1)=GTD(2,1,LS)*CDSDX(K,1) 
     *               +GTD(2,2,LS)*CDSDX(K,2) 
        CDZ(K,1,LS+1)=GTD(1,1,LS)*CDSDZ(K,1) 
     *               +GTD(1,2,LS)*CDSDZ(K,2) 
        CDZ(K,2,LS+1)=GTD(2,1,LS)*CDSDZ(K,1) 
     *               +GTD(2,2,LS)*CDSDZ(K,2) 
        DO 120 I=LS+1,NL-1 
          CDX(K,1,I+1)=GTD(1,1,I)*CDX(K,1,I) 
     *                +GTD(1,2,I)*CDX(K,2,I) 
          CDX(K,2,I+1)=GTD(2,1,I)*CDX(K,1,I) 
     *                +GTD(2,2,I)*CDX(K,2,I) 
          CUX(K,1,I)  =GRD(1,1,I)*CDX(K,1,I) 
     *                +GRD(1,2,I)*CDX(K,2,I) 
          CUX(K,2,I)  =GRD(2,1,I)*CDX(K,1,I) 
     *                +GRD(2,2,I)*CDX(K,2,I) 
          CDZ(K,1,I+1)=GTD(1,1,I)*CDZ(K,1,I) 
     *                +GTD(1,2,I)*CDZ(K,2,I) 
          CDZ(K,2,I+1)=GTD(2,1,I)*CDZ(K,1,I) 
     *                +GTD(2,2,I)*CDZ(K,2,I) 
          CUZ(K,1,I)  =GRD(1,1,I)*CDZ(K,1,I) 
     *                +GRD(1,2,I)*CDZ(K,2,I) 
          CUZ(K,2,I)  =GRD(2,1,I)*CDZ(K,1,I) 
     *                +GRD(2,2,I)*CDZ(K,2,I) 
  120   CONTINUE 
C 
  100 CONTINUE 
C 
      RETURN 
      END 
C 
C 
C *** Library for P-SV UPGOING/DOWNGOING COEFFICIENTS *** 
C 
      SUBROUTINE CUDPSV(OM) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 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,OM,WN,DQX,DQZ 
     *    ,AU(2,2),BU(2,2),AD(2,2),BD(2,2),CS(2,2),E1(2,2),E2(2,2) 
      COMMON /SOLY/SDEP,ODEP,LS,LO  
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     *  /DUPSVX/CDX(2001,2,20),CUX(2001,2,20),CUSUX(2001,2) 
     *         ,CDSUX(2001,2),CDSDX(2001,2),CUSDX(2001,2)  
     *  /DUPSVZ/CDZ(2001,2,20),CUZ(2001,2,20),CUSUZ(2001,2) 
     *         ,CDSUZ(2001,2),CDSDZ(2001,2),CUSDZ(2001,2)  
     *  /GRTPSV/GTD(2,2,0:20),GTU(2,2,0:20),GRD(2,2,0:20),GRU(2,2,0:20) 
     *  /WVNUM/WVN(2001),DWN,WNR(3),NWN 
C 
C *** CHECK FOR THE DIMENSION OF CD, CU, AND GTD-GRU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM CUDPSV: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
      NC=2001 
      IF(NWN.GT.NC)THEN 
         WRITE(10,*)' FROM CUDPSV: NWN.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** COMPUTATION OF GENERALIZED R/T MATRICES *** 
C 
      DO 100 K=1,NWN 
C 
        WN=dcmplx(WVN(K),0.d0) 
        CALL GNRTPSVc(OM,WN) 
C 
C *** COMPUTATION OF CD AND CU *** 
C 
        CALL MTXPSVc(OM,WN,LS,CMS,CMP,EE) 
C 
        DQX=-WN/6.2831853072d0 
        DQZ= WN/6.2831853072d0 
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)=E2(1,1)*DQX 
            CDSDX(K,2)=E2(2,1)*DQX 
            CUSDX(K,1)=(0.d0,0.d0)
            CUSDX(K,2)=(0.d0,0.d0)
            CDSDZ(K,1)=E2(1,2)*DQZ 
            CDSDZ(K,2)=E2(2,2)*DQZ 
            CUSDZ(K,1)=(0.d0,0.d0)
            CUSDZ(K,2)=(0.d0,0.d0)
C 
          ELSE 
C 
            CALL DDUPSVc(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)=E2(1,1)*DQX 
            CDSDX(K,2)=E2(2,1)*DQX 
            CUSDX(K,1)=GRD(1,1,1)*CDSDX(K,1) 
     *                  +GRD(1,2,1)*CDSDX(K,2) 
            CUSDX(K,2)=GRD(2,1,1)*CDSDX(K,1) 
     *                  +GRD(2,2,1)*CDSDX(K,2) 
            CDSDZ(K,1)=E2(1,2)*DQZ 
            CDSDZ(K,2)=E2(2,2)*DQZ 
            CUSDZ(K,1)=GRD(1,1,1)*CDSDZ(K,1) 
     *                  +GRD(1,2,1)*CDSDZ(K,2) 
            CUSDZ(K,2)=GRD(2,1,1)*CDSDZ(K,1) 
     *                  +GRD(2,2,1)*CDSDZ(K,2) 
C 
          END IF 
C  
        ELSE 
C 
          IF(LS.EQ.NL)THEN  
C 
            CALL DDUPSVc(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)=E2(1,1)*DQX 
            CUSUX(K,2)=E2(2,1)*DQX 
            CDSUX(K,1)=GRU(1,1,LS-1)*CUSUX(K,1) 
     *                +GRU(1,2,LS-1)*CUSUX(K,2) 
            CDSUX(K,2)=GRU(2,1,LS-1)*CUSUX(K,1) 
     *                +GRU(2,2,LS-1)*CUSUX(K,2) 
            CDSDX(K,1)=CS(1,1)*CUSUX(K,1)+CS(1,2)*CUSUX(K,2) 
            CDSDX(K,2)=CS(2,1)*CUSUX(K,1)+CS(2,2)*CUSUX(K,2) 
C 
            CUSUZ(K,1)=E2(1,2)*DQZ 
            CUSUZ(K,2)=E2(2,2)*DQZ 
            CDSUZ(K,1)=GRU(1,1,LS-1)*CUSUZ(K,1) 
     *                +GRU(1,2,LS-1)*CUSUZ(K,2) 
            CDSUZ(K,2)=GRU(2,1,LS-1)*CUSUZ(K,1) 
     *                +GRU(2,2,LS-1)*CUSUZ(K,2) 
            CDSDZ(K,1)=CS(1,1)*CUSUZ(K,1)+CS(1,2)*CUSUZ(K,2) 
            CDSDZ(K,2)=CS(2,1)*CUSUZ(K,1)+CS(2,2)*CUSUZ(K,2) 
C 
          ELSE 
C 
            CALL DDUPSVc(OM,WN,SDEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)=E2(1,1)*DQX 
            CUSUX(K,2)=E2(2,1)*DQX 
            CDSUX(K,1)=GRU(1,1,LS-1)*CUSUX(K,1) 
     *                +GRU(1,2,LS-1)*CUSUX(K,2) 
            CDSUX(K,2)=GRU(2,1,LS-1)*CUSUX(K,1) 
     *                +GRU(2,2,LS-1)*CUSUX(K,2) 
            CDSDX(K,1)=CS(1,1)*CUSUX(K,1)+CS(1,2)*CUSUX(K,2) 
            CDSDX(K,2)=CS(2,1)*CUSUX(K,1)+CS(2,2)*CUSUX(K,2) 
            CUSDX(K,1)=GRD(1,1,LS)*CDSDX(K,1) 
     *                +GRD(1,2,LS)*CDSDX(K,2) 
            CUSDX(K,2)=GRD(2,1,LS)*CDSDX(K,1) 
     *                +GRD(2,2,LS)*CDSDX(K,2) 
C 
            CUSUZ(K,1)=E2(1,2)*DQZ 
            CUSUZ(K,2)=E2(2,2)*DQZ 
            CDSUZ(K,1)=GRU(1,1,LS-1)*CUSUZ(K,1) 
     *                +GRU(1,2,LS-1)*CUSUZ(K,2) 
            CDSUZ(K,2)=GRU(2,1,LS-1)*CUSUZ(K,1) 
     *                +GRU(2,2,LS-1)*CUSUZ(K,2) 
            CDSDZ(K,1)=CS(1,1)*CUSUZ(K,1)+CS(1,2)*CUSUZ(K,2) 
            CDSDZ(K,2)=CS(2,1)*CUSUZ(K,1)+CS(2,2)*CUSUZ(K,2) 
            CUSDZ(K,1)=GRD(1,1,LS)*CDSDZ(K,1) 
     *                +GRD(1,2,LS)*CDSDZ(K,2) 
            CUSDZ(K,2)=GRD(2,1,LS)*CDSDZ(K,1) 
     *                +GRD(2,2,LS)*CDSDZ(K,2) 
C 
          ENDIF 
C 
        END IF 
C 
        IF(LS.EQ.1)GOTO 10 
          CUX(K,1,LS-1)=GTU(1,1,LS-1)*CUSUX(K,1) 
     *                 +GTU(1,2,LS-1)*CUSUX(K,2) 
          CUX(K,2,LS-1)=GTU(2,1,LS-1)*CUSUX(K,1) 
     *                 +GTU(2,2,LS-1)*CUSUX(K,2) 
          CUZ(K,1,LS-1)=GTU(1,1,LS-1)*CUSUZ(K,1) 
     *                 +GTU(1,2,LS-1)*CUSUZ(K,2) 
          CUZ(K,2,LS-1)=GTU(2,1,LS-1)*CUSUZ(K,1) 
     *                 +GTU(2,2,LS-1)*CUSUZ(K,2) 
        DO 110 I=LS-2,1,-1 
          CUX(K,1,I)  =GTU(1,1,I)*CUX(K,1,I+1) 
     *                +GTU(1,2,I)*CUX(K,2,I+1) 
          CUX(K,2,I)  =GTU(2,1,I)*CUX(K,1,I+1) 
     *                +GTU(2,2,I)*CUX(K,2,I+1) 
          CDX(K,1,I+1)=GRU(1,1,I)*CUX(K,1,I+1) 
     *                +GRU(1,2,I)*CUX(K,2,I+1) 
          CDX(K,2,I+1)=GRU(2,1,I)*CUX(K,1,I+1) 
     *                +GRU(2,2,I)*CUX(K,2,I+1) 
          CUZ(K,1,I)  =GTU(1,1,I)*CUZ(K,1,I+1) 
     *                +GTU(1,2,I)*CUZ(K,2,I+1) 
          CUZ(K,2,I)  =GTU(2,1,I)*CUZ(K,1,I+1) 
     *                +GTU(2,2,I)*CUZ(K,2,I+1) 
          CDZ(K,1,I+1)=GRU(1,1,I)*CUZ(K,1,I+1) 
     *                +GRU(1,2,I)*CUZ(K,2,I+1) 
          CDZ(K,2,I+1)=GRU(2,1,I)*CUZ(K,1,I+1) 
     *                +GRU(2,2,I)*CUZ(K,2,I+1) 
  110   CONTINUE 
        CDX(K,1,1)=GRU(1,1,0)*CUX(K,1,1)+GRU(1,2,0)*CUX(K,2,1) 
        CDX(K,2,1)=GRU(2,1,0)*CUX(K,1,1)+GRU(2,2,0)*CUX(K,2,1) 
        CDZ(K,1,1)=GRU(1,1,0)*CUZ(K,1,1)+GRU(1,2,0)*CUZ(K,2,1) 
        CDZ(K,2,1)=GRU(2,1,0)*CUZ(K,1,1)+GRU(2,2,0)*CUZ(K,2,1) 
C 
   10   IF(LS.EQ.NL)GOTO 100 
        CDX(K,1,LS+1)=GTD(1,1,LS)*CDSDX(K,1) 
     *               +GTD(1,2,LS)*CDSDX(K,2) 
        CDX(K,2,LS+1)=GTD(2,1,LS)*CDSDX(K,1) 
     *               +GTD(2,2,LS)*CDSDX(K,2) 
        CDZ(K,1,LS+1)=GTD(1,1,LS)*CDSDZ(K,1) 
     *               +GTD(1,2,LS)*CDSDZ(K,2) 
        CDZ(K,2,LS+1)=GTD(2,1,LS)*CDSDZ(K,1) 
     *               +GTD(2,2,LS)*CDSDZ(K,2) 
        DO 120 I=LS+1,NL-1 
          CDX(K,1,I+1)=GTD(1,1,I)*CDX(K,1,I) 
     *                +GTD(1,2,I)*CDX(K,2,I) 
          CDX(K,2,I+1)=GTD(2,1,I)*CDX(K,1,I) 
     *                +GTD(2,2,I)*CDX(K,2,I) 
          CUX(K,1,I)  =GRD(1,1,I)*CDX(K,1,I) 
     *                +GRD(1,2,I)*CDX(K,2,I) 
          CUX(K,2,I)  =GRD(2,1,I)*CDX(K,1,I) 
     *                +GRD(2,2,I)*CDX(K,2,I) 
          CDZ(K,1,I+1)=GTD(1,1,I)*CDZ(K,1,I) 
     *                +GTD(1,2,I)*CDZ(K,2,I) 
          CDZ(K,2,I+1)=GTD(2,1,I)*CDZ(K,1,I) 
     *                +GTD(2,2,I)*CDZ(K,2,I) 
          CUZ(K,1,I)  =GRD(1,1,I)*CDZ(K,1,I) 
     *                +GRD(1,2,I)*CDZ(K,2,I) 
          CUZ(K,2,I)  =GRD(2,1,I)*CDZ(K,1,I) 
     *                +GRD(2,2,I)*CDZ(K,2,I) 
  120   CONTINUE 
C 
  100 CONTINUE 
C 
      RETURN 
      END 
C 
c 
C *** SH DISPLACEMENT USING R/T MATRIX *** 
C 
      SUBROUTINE RTSH0(OM,K,WN,VLX) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 VSc,CD,CU,VS2,WS2,CMS,SM,EE(2,2) 
     *          ,CUSU,CDSU,CDSD,CUSD,DD,DU,VLX(2),OM,OM2 
      COMMON /SOLY/SDEP,ODEP,LS,LO 
     *       /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                    ,VS(20),QS(20),FS(20),THK(20),NL 
     *       /DUSH0/CD(2001,20),CU(2001,20) 
     *       ,CUSU(2001),CDSU(2001),CDSD(2001),CUSD(2001) 
C 
C *** CHECK FOR THE DIMENSION OF CD AND CU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM RTSH: NL.GT.NC ',NL,NC 
         STOP 
      END IF 
C 
C *** COMPUTATION OF VLX *** 
C 
      OM2=OM*OM 
      WN2=WN*WN 
C 
      QSe=FuncQS(OM,LO)
      VSc=VS(LO)*DCMPLX(1.D0,-0.5D0/QSe) 
      VS2=VSc*VSc 
      WS2=OM2/VS2 
      CMS=CDSQRT(WN2-WS2) 
      IF(dREAL(CMS).LT.0.d0)CMS=-CMS
C 
      SM=DNS(LO)*VS2 
      EE(1,1)=(1.d0,0.d0)
      EE(1,2)=(1.d0,0.d0)
      EE(2,1)=-SM*CMS 
      EE(2,2)= SM*CMS 
C 
      IF(LO.EQ.NL)THEN 
C         
        IF(LO.NE.LS)THEN 
          DD=CDEXP(-CMS*ODEP) 
          VLX(1)=EE(1,1)*DD*CD(K,LO) 
          VLX(2)=EE(2,1)*DD*CD(K,LO) 
        ELSE 
          IF(ODEP.GE.SDEP)THEN 
            DD=CDEXP(-CMS*(ODEP-SDEP)) 
            VLX(1)=EE(1,1)*DD*CDSD(K) 
            VLX(2)=EE(2,1)*DD*CDSD(K) 
          ELSE 
            DD=CDEXP(-CMS*ODEP) 
            DU=CDEXP(-CMS*(SDEP-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSU(K)+EE(1,2)*DU*CUSU(K) 
            VLX(2)=EE(2,1)*DD*CDSU(K)+EE(2,2)*DU*CUSU(K) 
          END IF 
        END IF 
C 
      ELSE 
C         
        IF(LO.NE.LS)THEN 
          DD=CDEXP(-CMS*ODEP) 
          DU=CDEXP(-CMS*(THK(LO)-ODEP)) 
          VLX(1)=EE(1,1)*DD*CD(K,LO)+EE(1,2)*DU*CU(K,LO) 
          VLX(2)=EE(2,1)*DD*CD(K,LO)+EE(2,2)*DU*CU(K,LO) 
        ELSE 
          IF(ODEP.GE.SDEP)THEN 
            DD=CDEXP(-CMS*(ODEP-SDEP)) 
            DU=CDEXP(-CMS*(THK(LO)-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSD(K)+EE(1,2)*DU*CUSD(K) 
            VLX(2)=EE(2,1)*DD*CDSD(K)+EE(2,2)*DU*CUSD(K) 
          ELSE 
            DD=CDEXP(-CMS*ODEP) 
            DU=CDEXP(-CMS*(SDEP-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSU(K)+EE(1,2)*DU*CUSU(K) 
            VLX(2)=EE(2,1)*DD*CDSU(K)+EE(2,2)*DU*CUSU(K) 
          END IF 
        END IF 
C 
      END IF 
C 
      RETURN 
      END 
C 
c 
c 
C *** SH DISPLACEMENT USING R/T MATRIX *** 
C 
      SUBROUTINE RTSH(OM,K,WN,VLX) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 VSc,CD,CU,VS2,WS2,CMS,SM,EE(2,2) 
     *          ,CUSU,CDSU,CDSD,CUSD,DD,DU,VLX(2),OM,OM2 
      COMMON /SOLY/SDEP,ODEP,LS,LO 
     *       /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                    ,VS(20),QS(20),FS(20),THK(20),NL 
     *       /DUSH/CD(2001,20),CU(2001,20) 
     *       ,CUSU(2001),CDSU(2001),CDSD(2001),CUSD(2001) 
C 
C *** CHECK FOR THE DIMENSION OF CD AND CU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM RTSH: NL.GT.NC ',NL,NC 
         STOP 
      END IF 
C 
C *** COMPUTATION OF VLX *** 
C 
      OM2=OM*OM 
      WN2=WN*WN 
C 
      QSe=FuncQS(OM,LO)
      VSc=VS(LO)*DCMPLX(1.D0,-0.5D0/QSe) 
      VS2=VSc*VSc 
      WS2=OM2/VS2 
      CMS=CDSQRT(WN2-WS2) 
      IF(dREAL(CMS).LT.0.d0)CMS=-CMS
C 
      SM=DNS(LO)*VS2 
      EE(1,1)=(1.d0,0.d0)
      EE(1,2)=(1.d0,0.d0)
      EE(2,1)=-SM*CMS 
      EE(2,2)= SM*CMS 
C 
      IF(LO.EQ.NL)THEN 
C         
        IF(LO.NE.LS)THEN 
          DD=CDEXP(-CMS*ODEP) 
          VLX(1)=EE(1,1)*DD*CD(K,LO) 
          VLX(2)=EE(2,1)*DD*CD(K,LO) 
        ELSE 
          IF(ODEP.GE.SDEP)THEN 
            DD=CDEXP(-CMS*(ODEP-SDEP)) 
            VLX(1)=EE(1,1)*DD*CDSD(K) 
            VLX(2)=EE(2,1)*DD*CDSD(K) 
          ELSE 
            DD=CDEXP(-CMS*ODEP) 
            DU=CDEXP(-CMS*(SDEP-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSU(K)+EE(1,2)*DU*CUSU(K) 
            VLX(2)=EE(2,1)*DD*CDSU(K)+EE(2,2)*DU*CUSU(K) 
          END IF 
        END IF 
C 
      ELSE 
C         
        IF(LO.NE.LS)THEN 
          DD=CDEXP(-CMS*ODEP) 
          DU=CDEXP(-CMS*(THK(LO)-ODEP)) 
          VLX(1)=EE(1,1)*DD*CD(K,LO)+EE(1,2)*DU*CU(K,LO) 
          VLX(2)=EE(2,1)*DD*CD(K,LO)+EE(2,2)*DU*CU(K,LO) 
        ELSE 
          IF(ODEP.GE.SDEP)THEN 
            DD=CDEXP(-CMS*(ODEP-SDEP)) 
            DU=CDEXP(-CMS*(THK(LO)-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSD(K)+EE(1,2)*DU*CUSD(K) 
            VLX(2)=EE(2,1)*DD*CDSD(K)+EE(2,2)*DU*CUSD(K) 
          ELSE 
            DD=CDEXP(-CMS*ODEP) 
            DU=CDEXP(-CMS*(SDEP-ODEP)) 
            VLX(1)=EE(1,1)*DD*CDSU(K)+EE(1,2)*DU*CUSU(K) 
            VLX(2)=EE(2,1)*DD*CDSU(K)+EE(2,2)*DU*CUSU(K) 
          END IF 
        END IF 
C 
      END IF 
C 
      RETURN 
      END 
C 
C 
C *** PSV DISPLACEMENT USING R/T MATRIX *** 
C 
      SUBROUTINE RTPSV0(OM,K,WNR,URX,URZ) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 CMP,CMS,EE(4,4),DD(2,2),DU(2,2),OM,WN 
     *    ,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/SDEP,ODEP,LS,LO 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     * /DUPSVX0/CDX(2001,2,20),CUX(2001,2,20),CUSUX(2001,2) 
     *        ,CDSUX(2001,2),CDSDX(2001,2),CUSDX(2001,2)  
     * /DUPSVZ0/CDZ(2001,2,20),CUZ(2001,2,20),CUSUZ(2001,2) 
     *        ,CDSUZ(2001,2),CDSDZ(2001,2),CUSDZ(2001,2)  
C 
C *** CHECK FOR THE DIMENSION OF CD AND CU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM RTPSV: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** COMPUTATION OF URX AND URZ *** 
C 
      WN=dcmplx(WNR,0.d0)
      CALL MTXPSVc(OM,WN,LO,CMS,CMP,EE) 
C 
      IF(LO.EQ.NL)THEN 
C         
        IF(LO.NE.LS)THEN 
C 
          CALL DDUPSVc(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)+E1(1,2)*CDX(K,2,LO) 
          URX(2,1)=E1(2,1)*CDX(K,1,LO)+E1(2,2)*CDX(K,2,LO) 
          URZ(1,1)=E1(1,1)*CDZ(K,1,LO)+E1(1,2)*CDZ(K,2,LO) 
          URZ(2,1)=E1(2,1)*CDZ(K,1,LO)+E1(2,2)*CDZ(K,2,LO) 
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)+E1(1,2)*CDX(K,2,LO) 
          URX(2,2)=E1(2,1)*CDX(K,1,LO)+E1(2,2)*CDX(K,2,LO) 
          URZ(1,2)=E1(1,1)*CDZ(K,1,LO)+E1(1,2)*CDZ(K,2,LO) 
          URZ(2,2)=E1(2,1)*CDZ(K,1,LO)+E1(2,2)*CDZ(K,2,LO) 
C 
        ELSE 
C 
          IF(ODEP.GE.SDEP)THEN 
C 
            CALL DDUPSVc(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)+E1(1,2)*CDSDX(K,2) 
            URX(2,1)=E1(2,1)*CDSDX(K,1)+E1(2,2)*CDSDX(K,2) 
            URZ(1,1)=E1(1,1)*CDSDZ(K,1)+E1(1,2)*CDSDZ(K,2) 
            URZ(2,1)=E1(2,1)*CDSDZ(K,1)+E1(2,2)*CDSDZ(K,2) 
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)+E1(1,2)*CDSDX(K,2) 
            URX(2,2)=E1(2,1)*CDSDX(K,1)+E1(2,2)*CDSDX(K,2) 
            URZ(1,2)=E1(1,1)*CDSDZ(K,1)+E1(1,2)*CDSDZ(K,2) 
            URZ(2,2)=E1(2,1)*CDSDZ(K,1)+E1(2,2)*CDSDZ(K,2) 
C 
          ELSE 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)+E1(1,2)*CDSUX(K,2) 
     *              +E2(1,1)*CUSUX(K,1)+E2(1,2)*CUSUX(K,2) 
            URX(2,1)=E1(2,1)*CDSUX(K,1)+E1(2,2)*CDSUX(K,2) 
     *              +E2(2,1)*CUSUX(K,1)+E2(2,2)*CUSUX(K,2) 
            URZ(1,1)=E1(1,1)*CDSUZ(K,1)+E1(1,2)*CDSUZ(K,2) 
     *              +E2(1,1)*CUSUZ(K,1)+E2(1,2)*CUSUZ(K,2) 
            URZ(2,1)=E1(2,1)*CDSUZ(K,1)+E1(2,2)*CDSUZ(K,2) 
     *              +E2(2,1)*CUSUZ(K,1)+E2(2,2)*CUSUZ(K,2) 
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)+E1(1,2)*CDSUX(K,2) 
     *              +E2(1,1)*CUSUX(K,1)+E2(1,2)*CUSUX(K,2) 
            URX(2,2)=E1(2,1)*CDSUX(K,1)+E1(2,2)*CDSUX(K,2) 
     *              +E2(2,1)*CUSUX(K,1)+E2(2,2)*CUSUX(K,2) 
            URZ(1,2)=E1(1,1)*CDSUZ(K,1)+E1(1,2)*CDSUZ(K,2) 
     *              +E2(1,1)*CUSUZ(K,1)+E2(1,2)*CUSUZ(K,2) 
            URZ(2,2)=E1(2,1)*CDSUZ(K,1)+E1(2,2)*CDSUZ(K,2) 
     *              +E2(2,1)*CUSUZ(K,1)+E2(2,2)*CUSUZ(K,2) 
C 
          END IF 
C 
        END IF 
C 
      ELSE 
C         
        IF(LO.NE.LS)THEN 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)+E1(1,2)*CDX(K,2,LO) 
     *              +E2(1,1)*CUX(K,1,LO)+E2(1,2)*CUX(K,2,LO) 
            URX(2,1)=E1(2,1)*CDX(K,1,LO)+E1(2,2)*CDX(K,2,LO) 
     *              +E2(2,1)*CUX(K,1,LO)+E2(2,2)*CUX(K,2,LO) 
            URZ(1,1)=E1(1,1)*CDZ(K,1,LO)+E1(1,2)*CDZ(K,2,LO) 
     *              +E2(1,1)*CUZ(K,1,LO)+E2(1,2)*CUZ(K,2,LO) 
            URZ(2,1)=E1(2,1)*CDZ(K,1,LO)+E1(2,2)*CDZ(K,2,LO) 
     *              +E2(2,1)*CUZ(K,1,LO)+E2(2,2)*CUZ(K,2,LO) 
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)+E1(1,2)*CDX(K,2,LO) 
     *              +E2(1,1)*CUX(K,1,LO)+E2(1,2)*CUX(K,2,LO) 
            URX(2,2)=E1(2,1)*CDX(K,1,LO)+E1(2,2)*CDX(K,2,LO) 
     *              +E2(2,1)*CUX(K,1,LO)+E2(2,2)*CUX(K,2,LO) 
            URZ(1,2)=E1(1,1)*CDZ(K,1,LO)+E1(1,2)*CDZ(K,2,LO) 
     *              +E2(1,1)*CUZ(K,1,LO)+E2(1,2)*CUZ(K,2,LO) 
            URZ(2,2)=E1(2,1)*CDZ(K,1,LO)+E1(2,2)*CDZ(K,2,LO) 
     *              +E2(2,1)*CUZ(K,1,LO)+E2(2,2)*CUZ(K,2,LO) 
C 
        ELSE 
C 
          IF(ODEP.GE.SDEP)THEN 
C 
            CALL DDUPSVc(OM,WN,ODEP-SDEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)+E1(1,2)*CDSDX(K,2) 
     *              +E2(1,1)*CUSDX(K,1)+E2(1,2)*CUSDX(K,2) 
            URX(2,1)=E1(2,1)*CDSDX(K,1)+E1(2,2)*CDSDX(K,2) 
     *              +E2(2,1)*CUSDX(K,1)+E2(2,2)*CUSDX(K,2) 
            URZ(1,1)=E1(1,1)*CDSDZ(K,1)+E1(1,2)*CDSDZ(K,2) 
     *              +E2(1,1)*CUSDZ(K,1)+E2(1,2)*CUSDZ(K,2) 
            URZ(2,1)=E1(2,1)*CDSDZ(K,1)+E1(2,2)*CDSDZ(K,2) 
     *              +E2(2,1)*CUSDZ(K,1)+E2(2,2)*CUSDZ(K,2) 
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)+E1(1,2)*CDSDX(K,2) 
     *              +E2(1,1)*CUSDX(K,1)+E2(1,2)*CUSDX(K,2) 
            URX(2,2)=E1(2,1)*CDSDX(K,1)+E1(2,2)*CDSDX(K,2) 
     *              +E2(2,1)*CUSDX(K,1)+E2(2,2)*CUSDX(K,2) 
            URZ(1,2)=E1(1,1)*CDSDZ(K,1)+E1(1,2)*CDSDZ(K,2) 
     *              +E2(1,1)*CUSDZ(K,1)+E2(1,2)*CUSDZ(K,2) 
            URZ(2,2)=E1(2,1)*CDSDZ(K,1)+E1(2,2)*CDSDZ(K,2) 
     *              +E2(2,1)*CUSDZ(K,1)+E2(2,2)*CUSDZ(K,2) 
C 
          ELSE 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)+E1(1,2)*CDSUX(K,2) 
     *              +E2(1,1)*CUSUX(K,1)+E2(1,2)*CUSUX(K,2) 
            URX(2,1)=E1(2,1)*CDSUX(K,1)+E1(2,2)*CDSUX(K,2) 
     *              +E2(2,1)*CUSUX(K,1)+E2(2,2)*CUSUX(K,2) 
            URZ(1,1)=E1(1,1)*CDSUZ(K,1)+E1(1,2)*CDSUZ(K,2) 
     *              +E2(1,1)*CUSUZ(K,1)+E2(1,2)*CUSUZ(K,2) 
            URZ(2,1)=E1(2,1)*CDSUZ(K,1)+E1(2,2)*CDSUZ(K,2) 
     *              +E2(2,1)*CUSUZ(K,1)+E2(2,2)*CUSUZ(K,2) 
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)+E1(1,2)*CDSUX(K,2) 
     *              +E2(1,1)*CUSUX(K,1)+E2(1,2)*CUSUX(K,2) 
            URX(2,2)=E1(2,1)*CDSUX(K,1)+E1(2,2)*CDSUX(K,2) 
     *              +E2(2,1)*CUSUX(K,1)+E2(2,2)*CUSUX(K,2) 
            URZ(1,2)=E1(1,1)*CDSUZ(K,1)+E1(1,2)*CDSUZ(K,2) 
     *              +E2(1,1)*CUSUZ(K,1)+E2(1,2)*CUSUZ(K,2) 
            URZ(2,2)=E1(2,1)*CDSUZ(K,1)+E1(2,2)*CDSUZ(K,2) 
     *              +E2(2,1)*CUSUZ(K,1)+E2(2,2)*CUSUZ(K,2) 
C 
          END IF 
C 
        END IF 
C 
      END IF 
C 
      RETURN 
      END 
C 
C 
C *** PSV DISPLACEMENT USING R/T MATRIX *** 
C 
      SUBROUTINE RTPSV(OM,K,WNR,URX,URZ) 
C 
      IMPLICIT REAL*8(A-H,O-Z) 
      COMPLEX*16 CMP,CMS,EE(4,4),DD(2,2),DU(2,2),OM,WN 
     *    ,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/SDEP,ODEP,LS,LO 
     *    /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *                 ,VS(20),QS(20),FS(20),THK(20),NL 
     * /DUPSVX/CDX(2001,2,20),CUX(2001,2,20),CUSUX(2001,2) 
     *        ,CDSUX(2001,2),CDSDX(2001,2),CUSDX(2001,2)  
     * /DUPSVZ/CDZ(2001,2,20),CUZ(2001,2,20),CUSUZ(2001,2) 
     *        ,CDSUZ(2001,2),CDSDZ(2001,2),CUSDZ(2001,2)  
C 
C *** CHECK FOR THE DIMENSION OF CD AND CU *** 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)' FROM RTPSV: NL.GT.NC !!!!!!!!!!!!!!!' 
         STOP 
      END IF 
C 
C *** COMPUTATION OF URX AND URZ *** 
C 
      WN=dcmplx(WNR,0.d0)
      CALL MTXPSVc(OM,WN,LO,CMS,CMP,EE) 
C 
      IF(LO.EQ.NL)THEN 
C         
        IF(LO.NE.LS)THEN 
C 
          CALL DDUPSVc(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)+E1(1,2)*CDX(K,2,LO) 
          URX(2,1)=E1(2,1)*CDX(K,1,LO)+E1(2,2)*CDX(K,2,LO) 
          URZ(1,1)=E1(1,1)*CDZ(K,1,LO)+E1(1,2)*CDZ(K,2,LO) 
          URZ(2,1)=E1(2,1)*CDZ(K,1,LO)+E1(2,2)*CDZ(K,2,LO) 
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)+E1(1,2)*CDX(K,2,LO) 
          URX(2,2)=E1(2,1)*CDX(K,1,LO)+E1(2,2)*CDX(K,2,LO) 
          URZ(1,2)=E1(1,1)*CDZ(K,1,LO)+E1(1,2)*CDZ(K,2,LO) 
          URZ(2,2)=E1(2,1)*CDZ(K,1,LO)+E1(2,2)*CDZ(K,2,LO) 
C 
        ELSE 
C 
          IF(ODEP.GE.SDEP)THEN 
C 
            CALL DDUPSVc(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)+E1(1,2)*CDSDX(K,2) 
            URX(2,1)=E1(2,1)*CDSDX(K,1)+E1(2,2)*CDSDX(K,2) 
            URZ(1,1)=E1(1,1)*CDSDZ(K,1)+E1(1,2)*CDSDZ(K,2) 
            URZ(2,1)=E1(2,1)*CDSDZ(K,1)+E1(2,2)*CDSDZ(K,2) 
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)+E1(1,2)*CDSDX(K,2) 
            URX(2,2)=E1(2,1)*CDSDX(K,1)+E1(2,2)*CDSDX(K,2) 
            URZ(1,2)=E1(1,1)*CDSDZ(K,1)+E1(1,2)*CDSDZ(K,2) 
            URZ(2,2)=E1(2,1)*CDSDZ(K,1)+E1(2,2)*CDSDZ(K,2) 
C 
          ELSE 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)+E1(1,2)*CDSUX(K,2) 
     *              +E2(1,1)*CUSUX(K,1)+E2(1,2)*CUSUX(K,2) 
            URX(2,1)=E1(2,1)*CDSUX(K,1)+E1(2,2)*CDSUX(K,2) 
     *              +E2(2,1)*CUSUX(K,1)+E2(2,2)*CUSUX(K,2) 
            URZ(1,1)=E1(1,1)*CDSUZ(K,1)+E1(1,2)*CDSUZ(K,2) 
     *              +E2(1,1)*CUSUZ(K,1)+E2(1,2)*CUSUZ(K,2) 
            URZ(2,1)=E1(2,1)*CDSUZ(K,1)+E1(2,2)*CDSUZ(K,2) 
     *              +E2(2,1)*CUSUZ(K,1)+E2(2,2)*CUSUZ(K,2) 
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)+E1(1,2)*CDSUX(K,2) 
     *              +E2(1,1)*CUSUX(K,1)+E2(1,2)*CUSUX(K,2) 
            URX(2,2)=E1(2,1)*CDSUX(K,1)+E1(2,2)*CDSUX(K,2) 
     *              +E2(2,1)*CUSUX(K,1)+E2(2,2)*CUSUX(K,2) 
            URZ(1,2)=E1(1,1)*CDSUZ(K,1)+E1(1,2)*CDSUZ(K,2) 
     *              +E2(1,1)*CUSUZ(K,1)+E2(1,2)*CUSUZ(K,2) 
            URZ(2,2)=E1(2,1)*CDSUZ(K,1)+E1(2,2)*CDSUZ(K,2) 
     *              +E2(2,1)*CUSUZ(K,1)+E2(2,2)*CUSUZ(K,2) 
C 
          END IF 
C 
        END IF 
C 
      ELSE 
C         
        IF(LO.NE.LS)THEN 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)+E1(1,2)*CDX(K,2,LO) 
     *              +E2(1,1)*CUX(K,1,LO)+E2(1,2)*CUX(K,2,LO) 
            URX(2,1)=E1(2,1)*CDX(K,1,LO)+E1(2,2)*CDX(K,2,LO) 
     *              +E2(2,1)*CUX(K,1,LO)+E2(2,2)*CUX(K,2,LO) 
            URZ(1,1)=E1(1,1)*CDZ(K,1,LO)+E1(1,2)*CDZ(K,2,LO) 
     *              +E2(1,1)*CUZ(K,1,LO)+E2(1,2)*CUZ(K,2,LO) 
            URZ(2,1)=E1(2,1)*CDZ(K,1,LO)+E1(2,2)*CDZ(K,2,LO) 
     *              +E2(2,1)*CUZ(K,1,LO)+E2(2,2)*CUZ(K,2,LO) 
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)+E1(1,2)*CDX(K,2,LO) 
     *              +E2(1,1)*CUX(K,1,LO)+E2(1,2)*CUX(K,2,LO) 
            URX(2,2)=E1(2,1)*CDX(K,1,LO)+E1(2,2)*CDX(K,2,LO) 
     *              +E2(2,1)*CUX(K,1,LO)+E2(2,2)*CUX(K,2,LO) 
            URZ(1,2)=E1(1,1)*CDZ(K,1,LO)+E1(1,2)*CDZ(K,2,LO) 
     *              +E2(1,1)*CUZ(K,1,LO)+E2(1,2)*CUZ(K,2,LO) 
            URZ(2,2)=E1(2,1)*CDZ(K,1,LO)+E1(2,2)*CDZ(K,2,LO) 
     *              +E2(2,1)*CUZ(K,1,LO)+E2(2,2)*CUZ(K,2,LO) 
C 
        ELSE 
C 
          IF(ODEP.GE.SDEP)THEN 
C 
            CALL DDUPSVc(OM,WN,ODEP-SDEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)+E1(1,2)*CDSDX(K,2) 
     *              +E2(1,1)*CUSDX(K,1)+E2(1,2)*CUSDX(K,2) 
            URX(2,1)=E1(2,1)*CDSDX(K,1)+E1(2,2)*CDSDX(K,2) 
     *              +E2(2,1)*CUSDX(K,1)+E2(2,2)*CUSDX(K,2) 
            URZ(1,1)=E1(1,1)*CDSDZ(K,1)+E1(1,2)*CDSDZ(K,2) 
     *              +E2(1,1)*CUSDZ(K,1)+E2(1,2)*CUSDZ(K,2) 
            URZ(2,1)=E1(2,1)*CDSDZ(K,1)+E1(2,2)*CDSDZ(K,2) 
     *              +E2(2,1)*CUSDZ(K,1)+E2(2,2)*CUSDZ(K,2) 
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)+E1(1,2)*CDSDX(K,2) 
     *              +E2(1,1)*CUSDX(K,1)+E2(1,2)*CUSDX(K,2) 
            URX(2,2)=E1(2,1)*CDSDX(K,1)+E1(2,2)*CDSDX(K,2) 
     *              +E2(2,1)*CUSDX(K,1)+E2(2,2)*CUSDX(K,2) 
            URZ(1,2)=E1(1,1)*CDSDZ(K,1)+E1(1,2)*CDSDZ(K,2) 
     *              +E2(1,1)*CUSDZ(K,1)+E2(1,2)*CUSDZ(K,2) 
            URZ(2,2)=E1(2,1)*CDSDZ(K,1)+E1(2,2)*CDSDZ(K,2) 
     *              +E2(2,1)*CUSDZ(K,1)+E2(2,2)*CUSDZ(K,2) 
C 
          ELSE 
C 
            CALL DDUPSVc(OM,WN,ODEP,CMS,CMP,DD) 
            CALL DDUPSVc(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)+E1(1,2)*CDSUX(K,2) 
     *              +E2(1,1)*CUSUX(K,1)+E2(1,2)*CUSUX(K,2) 
            URX(2,1)=E1(2,1)*CDSUX(K,1)+E1(2,2)*CDSUX(K,2) 
     *              +E2(2,1)*CUSUX(K,1)+E2(2,2)*CUSUX(K,2) 
            URZ(1,1)=E1(1,1)*CDSUZ(K,1)+E1(1,2)*CDSUZ(K,2) 
     *              +E2(1,1)*CUSUZ(K,1)+E2(1,2)*CUSUZ(K,2) 
            URZ(2,1)=E1(2,1)*CDSUZ(K,1)+E1(2,2)*CDSUZ(K,2) 
     *              +E2(2,1)*CUSUZ(K,1)+E2(2,2)*CUSUZ(K,2) 
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)+E1(1,2)*CDSUX(K,2) 
     *              +E2(1,1)*CUSUX(K,1)+E2(1,2)*CUSUX(K,2) 
            URX(2,2)=E1(2,1)*CDSUX(K,1)+E1(2,2)*CDSUX(K,2) 
     *              +E2(2,1)*CUSUX(K,1)+E2(2,2)*CUSUX(K,2) 
            URZ(1,2)=E1(1,1)*CDSUZ(K,1)+E1(1,2)*CDSUZ(K,2) 
     *              +E2(1,1)*CUSUZ(K,1)+E2(1,2)*CUSUZ(K,2) 
            URZ(2,2)=E1(2,1)*CDSUZ(K,1)+E1(2,2)*CDSUZ(K,2) 
     *              +E2(2,1)*CUSUZ(K,1)+E2(2,2)*CUSUZ(K,2) 
C 
          END IF 
C 
        END IF 
C 
      END IF 
C 
      RETURN 
      END 
c
c 
c 
c *** Complex Bessel and Neumann Functions of the 1st order *** 
c 
      subroutine CBJN1 (X,BJ1,BN1) 
       
      IMPLICIT REAL*8 (A-H,O-Z)            
      complex*16 X,BJ1,BN1,z,z1,aa,co,si,X1,X2,X3            
      DATA a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15 
     *   /  5.0         D-1,  1.666666667 D-1, 
     *      8.333333333 D-2,  5.0         D-2, 
     *      3.333333333 D-2,  2.380952381 D-2, 
     *      1.785714286 D-2,  1.388888889 D-2, 
     *      1.111111111 D-2,  9.090909091 D-3, 
     *      7.575757576 D-3,  6.41025641  D-3, 
     *      5.494505495 D-3,  4.761904762 D-3, 
     *      4.166666666 D-3 / 
      DATA b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15 
     * /0.50000000000000 D0, 1.25000000000000 D0,     
     *  1.66666666666666 D0, 1.95833333333333 D0,      
     *  2.18333333333333 D0, 2.36666666666667 D0,      
     *  2.52142857142857 D0, 2.65535714285714 D0,      
     *  2.77341269841270 D0, 2.87896825396825 D0,      
     *  2.97442279942280 D0, 3.06154401154401 D0,      
     *  3.14167221667222 D0, 3.21584804084805 D0,      
     *  3.28489565989566 D0 /     
      DATA pi / 3.141592654 D0 / 
      DATA eu / 0.5772157 D0 / 
c 
      if(cdabs(x).gt.9.d0)goto 10 
c 
      a=1.d0 
      z1=x*0.5d0 
      z=z1*z1                        
      BJ1=z1*(a-z*a1*(a-z*a2*(a-z*a3*(a-z*a4*(a-z*a5*(a-z*a6* 
     *   (a-z*a7*(a-z*a8*(a-z*a9*(a-z*a10*(a-z*a11*(a-z*a12*  
     *   (a-z*a13*(a-z*a14*(a-z*a15))))))))))))))) 
      BN1=z1*(b1-z*a1*(b2-z*a2*(b3-z*a3*(b4-z*a4*(b5-z*a5*(b6-z*a6* 
     *   (b7-z*a7*(b8-z*a8*(b9-z*a9*(b10-z*a10*(b11-z*a11*(b12-z* 
     *   a12*(b13-z*a13*(b14-z*a14*(b15-z*a15))))))))))))))) 
      BN1=2.d0*((cdlog(z1)+eu)*BJ1-1.d0/x-BN1)/pi 
      goto 20 
c 
   10 aa=cdsqrt(pi*x) 
      co=cdcos(x) 
      si=cdsin(x) 
      x1=0.375d0/x 
      x2=0.1171875d0/(x*x) 
      x3=0.102539063d0/(x*x*x) 
      BJ1= (si*(1.d0+x1+x2-x3)-co*(1.d0-x1+x2+x3))/aa  
      BN1=-(co*(1.d0+x1+x2-x3)+si*(1.d0-x1+x2+x3))/aa  
c  
   20 return 
      end       
c 
c 
c 
c *** Complex Bessel and Neumann Functions of the 0th order *** 
c 
      subroutine CBJN0 (X,BJ0,BN0) 
c 
      IMPLICIT REAL*8 (A-H,O-Z) 
      complex*16 X,BJ0,BN0,z,z1,aa,co,si,X1,X2,X3            
      DATA a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15 
     *   /  2.5         D-1,  1.111111111 D-1, 
     *      6.25        D-2,  4.0         D-2, 
     *      2.777777778 D-2,  2.040816327 D-2, 
     *      1.5625      D-2,  1.234567901 D-2, 
     *      1.0         D-2,  8.26446281  D-3, 
     *      6.944444444 D-3,  5.917159763 D-3, 
     *      5.102040816 D-3,  4.444444445 D-3, 
     *      3.90625     D-3 / 
      DATA b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15 
     * /1.00000000000000 D0, 1.50000000000000 D0,     
     *  1.83333333333333 D0, 2.08333333333333 D0,      
     *  2.28333333333333 D0, 2.45000000000000 D0,      
     *  2.59285714285714 D0, 2.71785714285714 D0,      
     *  2.82896825396825 D0, 2.92896825396825 D0,      
     *  3.01987734487734 D0, 3.10321067821068 D0,      
     *  3.18013375513376 D0, 3.25156232656233 D0,      
     *  3.31822899322899 D0 /     
      DATA pi / 3.141592654 D0 / 
      DATA eu / 0.5772157 D0 / 
c       
      if(cdabs(x).gt.9.d0)goto 10 
c       
      a=1.d0 
      z1=x*0.5d0            
      z=z1*z1            
      BJ0=a-z*(a-z*a1*(a-z*a2*(a-z*a3*(a-z*a4*(a-z*a5*(a-z*a6* 
     *   (a-z*a7*(a-z*a8*(a-z*a9*(a-z*a10*(a-z*a11*(a-z*a12*  
     *   (a-z*a13*(a-z*a14*(a-z*a15))))))))))))))) 
      BN0=z*(b1-z*a1*(b2-z*a2*(b3-z*a3*(b4-z*a4*(b5-z*a5*(b6-z*a6* 
     *   (b7-z*a7*(b8-z*a8*(b9-z*a9*(b10-z*a10*(b11-z*a11*(b12-z* 
     *   a12*(b13-z*a13*(b14-z*a14*(b15-z*a15))))))))))))))) 
      BN0=2.d0*((cdlog(z1)+eu)*BJ0+BN0)/pi 
      goto 20 
c 
   10 aa=cdsqrt(pi*x) 
      co=cdcos(x) 
      si=cdsin(x) 
      x1=0.125d0/x 
      x2=0.0703125d0/(x*x) 
      x3=0.073242188d0/(x*x*x) 
      BJ0=(co*(1.d0-x1-x2+x3)+si*(1.d0+x1-x2-x3))/aa  
      BN0=(si*(1.d0-x1-x2+x3)-co*(1.d0+x1-x2-x3))/aa  
c  
   20 return    
      end 
c 
c 
c *** Bessel of the 0th and 1st orders *** 
c 
      subroutine BJ01 (X,BJ0,BJ1) 
c 
      IMPLICIT REAL*8 (A-H,O-Z) 
      DATA a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15 
     *   /  2.5         D-1,  1.111111111 D-1, 
     *      6.25        D-2,  4.0         D-2, 
     *      2.777777778 D-2,  2.040816327 D-2, 
     *      1.5625      D-2,  1.234567901 D-2, 
     *      1.0         D-2,  8.26446281  D-3, 
     *      6.944444444 D-3,  5.917159763 D-3, 
     *      5.102040816 D-3,  4.444444445 D-3, 
     *      3.90625     D-3 / 
      DATA b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15 
     *   /  5.0         D-1,  1.666666667 D-1, 
     *      8.333333333 D-2,  5.0         D-2, 
     *      3.333333333 D-2,  2.380952381 D-2, 
     *      1.785714286 D-2,  1.388888889 D-2, 
     *      1.111111111 D-2,  9.090909091 D-3, 
     *      7.575757576 D-3,  6.41025641  D-3, 
     *      5.494505495 D-3,  4.761904762 D-3, 
     *      4.166666666 D-3 / 
      DATA pi / 3.141592654 D0 / 
c 
      if(dabs(x).gt.9.d0)goto 10 
c 
      a=1.d0 
      z1=x*0.5d0 
      z=z1*z1                        
      BJ0=a-z*(a-z*a1*(a-z*a2*(a-z*a3*(a-z*a4*(a-z*a5*(a-z*a6* 
     *   (a-z*a7*(a-z*a8*(a-z*a9*(a-z*a10*(a-z*a11*(a-z*a12*  
     *   (a-z*a13*(a-z*a14*(a-z*a15))))))))))))))) 
      BJ1=z1*(a-z*b1*(a-z*b2*(a-z*b3*(a-z*b4*(a-z*b5*(a-z*b6* 
     *   (a-z*b7*(a-z*b8*(a-z*b9*(a-z*b10*(a-z*b11*(a-z*b12*  
     *   (a-z*b13*(a-z*b14*(a-z*b15))))))))))))))) 
      goto 20 
c 
   10 aa=dsqrt(pi*x) 
      co=dcos(x) 
      si=dsin(x) 
      x1=0.125d0/x 
      x2=0.0703125d0/(x*x) 
      x3=0.073242188d0/(x*x*x) 
      BJ0=(co*(1.d0-x1-x2+x3)+si*(1.d0+x1-x2-x3))/aa  
      x1=0.375d0/x 
      x2=0.1171875d0/(x*x) 
      x3=0.102539063d0/(x*x*x) 
      BJ1= (si*(1.d0+x1+x2-x3)-co*(1.d0-x1+x2+x3))/aa  
c  
   20 return 
      end       
c
c
c
c *** Quality Factor of Vs ***
c
      Function FuncQS(OM,L)
c
      IMPLICIT REAL*8 (A-H,O-Z) 
      complex*16 OM            
      COMMON /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *            ,VS(20),QS(20),FS(20),THK(20),NL 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)'FROM OTDAT:NL>NC',NL,NC 
         STOP 
      END IF 
c
      OMR=dreal(OM)
      if(OMR.eq.0.d0)then
        FuncQS=QS(L)
      else
        freq=dreal(om)/6.2831853072d0
        FuncQS=QS(L)*freq**FS(L)
      end if
c
      return
      end    
c
c
c
c *** Quality Factor of Vp ***
c
      Function FuncQP(OM,L)
c
      IMPLICIT REAL*8 (A-H,O-Z) 
      complex*16 OM            
      COMMON /STRC/DNS(20),VP(20),QP(20),FP(20) 
     *            ,VS(20),QS(20),FS(20),THK(20),NL 
C 
      NC=20 
      IF(NL.GT.NC)THEN 
         WRITE(10,*)'FROM OTDAT:NL>NC',NL,NC 
         STOP 
      END IF 
c
      OMR=dreal(OM)
      if(OMR.eq.0.d0)then
        FuncQP=QP(L)
      else
        freq=dreal(om)/6.2831853072d0
        FuncQP=QP(L)*freq**FP(L)
      end if
c
      return
      end    


