c     program psv1d (kennett)
      program psv1d
      parameter (nlay=50)
      parameter (nlay4=4*nlay)
      parameter (nrec=20)
      parameter (ntmax=8192)
      parameter (nfreq=4097)
ccc      implicit none
      real    th(nlay),dens(nlay),beta0(nlay),alpha0(nlay),
     $        qs(nlay),qp(nlay),thickness(nlay)
      real    zr(nrec)
      character*40 filein,fileoutsh,fileoutpsv
      character*40 kname,accfile,filein_defaults
      character*3 ksuf(20)

c
      real    pi,pi2,pil
      real freq0,fmin,fmax,q,eq,teta,dfreq,aw,om0,freq,rw,omm,
     $     adr,phi,qsi,piqs,qpi,piqp,tet,qp0,qs0
      real ftf(nfreq),acc0(ntmax),acc1(ntmax)
      real period(201),fs0(201),sa(201),sv(201),sd(201),
     $     ttsa(201),ttsv(201),ttsd(201)
      complex alpha(nlay),beta(nlay),wa(nlay),wb(nlay),wa2(nlay),
     $        wb2(nlay),wza(nlay),wzb(nlay),f(nlay4,3)
      complex ai,omega,wx2,wz0,wx,wx0,wx02,cgam,cnu,
     $        ad,cqs,cqp,cds,cdp,wza2,wzb2,
     $        f1,f2,f3,f4,c1,c2,c3,u1,u2,u3,u4,w1,w2,w3,w4,
     $        uh0,uv0,uh0p,uh0s,uv0p,uv0s,v0,
     $        phaspu,phaspd,phassu,phassd,
     $        u(nfreq,nrec),w(nfreq,nrec),v(nfreq,nrec)
      complex sp0(nfreq),sp(nfreq)
      integer ln,nr,nf,nf1,mode,jcas,jfr,li,li1,li2,li3,li4,
     $        n,mx0,irec,i,il0
      integer izr(nrec)
c
      data ksuf/3h.1 ,3h.2 ,3h.3 ,3h.4 ,3h.5 ,3h.6 ,3h.7 ,3h.8 ,3h.9 ,
     1  3h.10,3h.11,3h.12,3h.13,3h.14,3h.15,3h.16,3h.17,3h.18,3h.19,
     1  3h.20/
c
      namelist/don1d/freq0,eq,nf,fmin,fmax,q,teta,mode,jcas,
     $               nr,zr,inputacc,accfile

c
      ai=(0.,1.)
      pi=3.141592653
      pi2=pi+pi
      lsignft=-1
      lsignft1=-lsignft
c
c Initialisations pour le calcul des spectres de reponse
c
      fmin=0.05
      fmax=50.
      nper=201
      rf=alog10(50./0.05)
      rf=rf/float(nper-1)
      rf=10.**rf
      fr=50.
      do ip=1,nper
        period(ip)=1./fr
        fr=fr/rf
        enddo
c 
c  Reading standard parameters 
c
      filein_defaults="file_PSVSH_DEFAULTS.in"
c      write(*,*) filein_defaults
      open(10,file=filein_defaults)
      read(10,don1d,end=80)
      close(10)
c      write(6,*) freq0,eq,nf,fmin,fmax,q,teta,mode,jcas,nr,zr,inputacc,accfile

c
c  Reading ground model parameters
c

c2500  jcas=0

c      write(6,*) "input model ?"
      read(5,*) filein
c      write(6,*) "INPUT MODEL ",filein
      open(11,file=filein)
      read(11,*) ln
      do i=1,ln
         read(11,*) thickness(i),alpha0(i),beta0(i),
     1             dens(i),qp(i),qs(i)
      enddo
      close(11)

      th(1)=0; 
      do i=2,ln
         th(i)=thickness(i-1)+th(i-1)
      enddo
      close(11)

      lk=longcar(filein)-5

cc
      if(inputacc.eq.1) then
        call readr_ascii1(accfile,acc0,nacc,tbeg,dt)
        xnt=alog10(float(nacc))/alog10(2.)
        nt=int(xnt)+1
        nt=2**nt
        nf=nt/2
        tmax=dt*float(nt)
        fmin=0.
        fmax=0.5/dt
        q=1.e+20
        scale=1./float(nt)
        if(nacc.ge.nt) go to 9
          do it=nacc+1,nt
            acc0(it)=0.
            enddo
9         continue
                       else
c
        xnt=alog10(float(nf))/alog10(2.)
        nt=int(xnt)+2
        nt=2**nt
c        nf=nt/2
c        fmin=0.
        dt=0.5/fmax
        tmax=dt*float(nt)
        q=1.e+20
        scale=1./float(nt)
          do it=1,nt
            acc0(it)=0.
            enddo
            acc0(49)=2.
            acc0(50)=10.
            acc0(51)=2.
c
                        endif
        call rcft(acc0,sp0,nt,lsignft)
c
      nf1=nf
      dfreq=(fmax-fmin)/(nf-1.)
      aw=-pi/q
      om0=pi2*freq0
c      write(6,*) fmin, dfreq,fmax
c      write(6,*) scale,nt,nf1
c
c  *** indices des recepteurs
      do 10 ir=1,nr
        z=zr(ir)
        il0=1
        do 15 li=2,ln
          if(z.le.th(li)) go to 16
15        il0=il0+1
16      izr(ir)=il0
c        write(6,*) "ir=",ir,"zr=",zr(ir),"couche:il0=",izr(ir)
10    continue
c
      freq=fmin
      do 100 jfr=1,nf1
      freq=fmin+(jfr-1.)*dfreq
      if(freq.eq.0.) freq=0.05*dfreq
      rw=freq*pi2
      omega=cmplx(rw,aw)
      omm=sqrt(rw**2 + aw**2)
      adr=alog(omm/om0)
      if(rw.ne.0.) then
         phi=atan(aw/rw)
                   else
         if(aw.gt.0.) phi=pi/2.
         if(aw.lt.0.) phi=-pi/2.
                   end if
      ad=adr + ai*phi
      df=freq - freq0
      if(df.lt.0.) df=0.
      do 600 li=1,ln
        qsi=qs(li)*(1. + eq*df)
        piqs=1./(pi*qsi)
        cqs=1. - .5*ai/qsi
        cds=1. - piqs*ad
        beta(li)=beta0(li)/(cds*cqs)
c       beta(li)=beta0(li)*(1. + .5*ai/qsi + piqs*adr)
        qpi=qp(li)*(1. + eq*df)
        piqp=1./(pi*qpi)
        cqp=1. - .5*ai/qpi
        cdp=1. - piqp*ad
        alpha(li)=alpha0(li)/(cdp*cqp)
c       alpha(li)=alpha0(li)*(1. + .5*ai/qpi + piqp*adr)
        wb(li)=omega/beta(li)
        wb2(li)=wb(li)*wb(li)
        wa(li)=omega/alpha(li)
        wa2(li)=wa(li)*wa(li)
600     continue
c
      tet=teta*pi/180.
      if(mode.eq.1) then
        wx0=wa(ln)*sin(tet)
        mx0=n*freq*sin(tet)/alpha0(ln)
        c1=-ai/wa(ln)
                    else
        wx0=wb(ln)*sin(tet)
        mx0=n*freq*sin(tet)/beta0(ln)
        c1= ai/wb(ln)
                    end if
      wx02=wx0*wx0
c
      call kenpsv(jcas,wx0,omega,ln,th,dens,alpha,beta,f)
c
c  si mode =1 ou 2
c  1 = onde p montante
c  2 = onde p descendante
c  3 = onde sv montante
c  4 = onde sv descendante
c
c  si mode = 3
c    1 = onde sh montante
c    1 = onde sh descendante
c
      do 300 li=1,ln
        li1=4*li-3
        li2=li1+1
        li3=li2+1
        li4=li3+1
        wza2=wa2(li) - wx02
        wzb2=wb2(li) - wx02
        wza(li)=csqrt(wza2)
        wzb(li)=csqrt(wzb2)
        if(aimag(wza(li)).gt.0.) wza(li)=-wza(li)
        if(aimag(wzb(li)).gt.0.) wzb(li)=-wzb(li)
c       write(6,6300) freq,cabs(f(li1,mode)),cabs(f(li2,mode)),
c    1                cabs(f(li3,mode)),cabs(f(li4,mode))
300     continue
6300  format(f10.4,4e15.4)
c
      do 110 ir=1,nr
        li=izr(ir)
        li1=4*li-3
        li2=li1+1
        li3=li2+1
        li4=li3+1
        lish1=2*li-1
        lish2=lish1+1
        z=zr(ir)-th(li)
        phaspu=cexp(ai*wza(li)*z)
        phassu=cexp(ai*wzb(li)*z)
        phaspd=1./phaspu
        phassd=1./phassu
c
        u1=-ai*wx0
        u4= ai*wzb(li)
        w1= ai*wza(li)
c
        f1=f(li1,mode)*phaspu
        f2=f(li2,mode)*phaspd
        f3=f(li3,mode)*phassu
        f4=f(li4,mode)*phassd
        uh0 = u1*(f1 + f2) + u4*(f4 - f3)
        uv0 = w1*(f1 - f2) + u1*(f3 + f4)
        u(jfr,ir)=uh0*c1
        w(jfr,ir)=uv0*c1
        v0=f(lish1,3)*phassu + f(lish2,3)*phassd
        v(jfr,ir)=v0
110     continue
        write(6,501) freq,v(jfr,1),cabs(v(jfr,1))
100     continue
c
c   Saving the whole results in single ascii files
ccc          xr=0.
ccc      if(mode.eq.1.or.mode.eq.2) then
ccc        lk=longcar(filein)-3
ccc        fileoutpsv=filein(1:lk)//'.pp'
ccc        if(mode.eq.2) fileoutpsv=filein(1:lk)//'.sv'
ccc        open(20,file=fileoutpsv)
ccc        write(20,1102) filein
ccc        write(20,1100) nr
ccc          do ir=1,nr
ccc            write(20,1100) ir,nf,fmin,fmax,xr,zr(ir)
ccc            write(20,1101) (u(if,ir)/2.,if=1,nf1)
ccc            write(20,1101) (w(if,ir)/2.,if=1,nf1)
ccc            enddo
ccc        close(20)
ccc                                   endif
ccc      if(mode.eq.3) then
ccc        lk=longcar(filein)-3
ccc        fileoutsh=filein(1:lk)//'.sh'
ccc        open(21,file=fileoutsh)
ccc        write(21,1102) filein
ccc        write(21,1100) nr
ccc        write(21,1100) ir,nf,fmin,fmax,xr,zr(ir)
ccc        do ir=1,nr
ccc            write(21,1101) (v(if,ir)/2.,if=1,nf1)
ccc            enddo
ccc        close(21)
ccc                    endif
c       
      do 200 ir=1,nr
      if(mode.eq.1.or.mode.eq.2) then
        lk=longcar(filein)
        kname=filein(1:lk)//'_pp'
        if(mode.eq.2) kname=filein(1:lk)//'_sv'
        lk3=lk+3
        kname=kname(1:lk3)//'_ftf_u'//ksuf(ir)
        do if=1,nf1
          ftf(if)=cabs(u(if,ir))
          enddo
ccc        call writer_ascii1(kname,ftf,nf1,fmin,dfreq)
        call writec_ascii1(kname,u(1,ir),nf1,fmin,dfreq)
          do if=1,nf1
            sp(if)=u(if,ir)*sp0(if)*scale
            enddo
          call crft(sp,acc1,nt,lsignft1)
          kname=kname(1:lk3)//'_acc_u'//ksuf(ir)
c          call writer_ascii1(kname,acc1,nt,0.,dt)
c
Calcul des spectres de reponse
        call pcno3(0.05,nper,period,nt,acc1,fs0,sd,sv,sa,
     1   ttsd,ttsv,ttsa,dt,6,6)
        kname=filein(1:lk)//'_spr_u'//ksuf(ir)
          call writer_ascii2(kname,period,sa,nper)
c
        kname=kname(1:lk3)//'_ftf_w'//ksuf(ir)
        do if=1,nf1
          ftf(if)=cabs(w(if,ir))
          enddo
ccc        call writer_ascii1(kname,ftf,nf1,fmin,dfreq)
        call writec_ascii1(kname,w(1,ir),nf1,fmin,dfreq)
          do if=1,nf1
            sp(if)=w(if,ir)*sp0(if)*scale
            enddo
          call crft(sp,acc1,nt,lsignft1)
          kname=kname(1:lk3)//'_acc_w'//ksuf(ir)
c          call writer_ascii1(kname,acc1,nt,0.,dt)
c
Calcul des spectres de reponse
        call pcno3(0.05,nper,period,nt,acc1,fs0,sd,sv,sa,
     1   ttsd,ttsv,ttsa,dt,6,6)
        kname=filein(1:lk)//'_spr_w'//ksuf(ir)
c          call writer_ascii2(kname,period,sa,nper)
c
                                  endif
c
        if(mode.eq.3) then
        lk=longcar(filein)
        kname=filein(1:lk)//'_ftf_v'//ksuf(ir)
        do if=1,nf1
          ftf(if)=cabs(v(if,ir))
          enddo
ccc        call writer_ascii1(kname,ftf,nf1,fmin,dfreq)
c        call writec_ascii1(kname,v(1,ir),nf1,fmin,dfreq)
          do if=1,nf1
            sp(if)=v(if,ir)*sp0(if)*scale
            enddo
          call crft(sp,acc1,nt,lsignft1)
          kname=filein(1:lk)//'_acc_v'//ksuf(ir)
c          call writer_ascii1(kname,acc1,nt,0.,dt)
c
Calcul des spectres de reponse
        call pcno3(0.05,nper,period,nt,acc1,fs0,sd,sv,sa,
     1   ttsd,ttsv,ttsa,dt,6,6)
        kname=filein(1:lk)//'_spr_v'//ksuf(ir)
c          call writer_ascii2(kname,period,sa,nper)

                       endif
c
200         continue
1100   format(2i5,4f10.2)
1101   format(2f8.4)
1102   format(" fichier: ",a20)
        close(20)
        close(21)
c        go to 2500
501      format(1x,f9.4," , ",3(f12.7," , "))
6000    format(1x,'frequence :',f10.4,4x,'u =',2f10.4,4x,'w =',2f10.4)
6001    format(10x,'  ondes p :',5x,'u =',2f10.4,4x,'w =',2f10.4)
6002    format(10x,'  ondes s :',5x,'u =',2f10.4,4x,'w =',2f10.4)
78      format(16f8.4)
80      stop
        end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine kenpsv(jcas,ckx,comega,ln,th,dens,calpha,cbeta,cfwave)
c
      parameter (nlay=50)
      parameter (nlay4=4*nlay)
c
      implicit real   (a-b,d-h,o-z)
      implicit complex    (c)
c
      real th(nlay),dens(nlay)
      complex calpha(nlay),cbeta(nlay),cfwave(nlay4,3)
c
      complex    ckx,comega
      complex    ai,omega,omega2
      complex     me1,me2,nt,mt,fup,
     &            u,ru,rd,tu,td
c
      common /dim1a/ ai,pi,pi2,omega,omega2,cwx,cwx2
      common /dim1e/ nc,hc(nlay),cvp(nlay),cvs(nlay),rho(nlay)
      common /dim2a/ cka(nlay),ckb(nlay),cka2(nlay),ckb2(nlay),
     &               cnu(nlay),cgam(nlay)
      common /dim2c/ rd(nlay,2,2),ru(nlay,2,2),td(nlay,2,2),
     &               tu(nlay,2,2),me1(nlay),me2(nlay)
      common /dim2d/ nt(nlay,2,2),mt(nlay,2,2)
      common /dim2e/ fup(nlay,2,2)
      common /dim2f/ su1(2),su2(2)
      
      ai=(0.,1.)
      pi=3.14159265359
      pi2=pi+pi

c               si th(1)=0 on donne les profondeurs des interfaces, sinon
c               on donne les epaisseurs des couches
c++++++++++
      nc=ln
      if (th(1).eq.0.) then
        do 1 ic=1,nc-1
          hc(ic)=th(ic+1)-th(ic)
1         continue
                       else
        do 2 ic=1,nc
          hc(ic)=th(ic)
2         continue
                       endif

      cwx=ckx
      cwx2=cwx*cwx
      omega=comega
      omega2=omega*omega
      do 10 ic=1,nc
        rho(ic)=dens(ic)
        cvp(ic)=calpha(ic)
        cvs(ic)=cbeta(ic)
        cka(ic)=omega/cvp(ic)
        ckb(ic)=omega/cvs(ic)
        ckb2(ic)=ckb(ic)*ckb(ic)
        cka2(ic)=cka(ic)*cka(ic)
        cc=cka2(ic)-cwx2
        cnu(ic)=csqrt(cc)
        if (aimag(cnu(ic)).gt.0.) cnu(ic)=-cnu(ic)
        cc=ckb2(ic)-cwx2
        cgam(ic)=csqrt(cc)
        if (aimag(cgam(ic)).gt.0.) cgam(ic)=-cgam(ic)
10      continue

c+++++++++++++
c              Calcul des coefficients de reflexion/transmission
c             Matrice de Reflection/Transmission et Dephasage
c+++++++++++++

      call reflect1(jcas)
      
c+++++++++++++
c              Calcul des matrices de reflectivite : mt(),mb(),nt(),nb()
c              (rapport des differents potentiels montant/descendant
c                        en haut et en bas de chaque couche)
c+++++++++++++

      call reflect2

c+++++++++++++
c              Calcul des potentiels des ondes P et S, montantes et
c              descendantes, dans chaque couche, pour
c                - une onde P montante (jcas=0) dans la couche ln
c                - une onde S montante (jcas=0) dans la couche ln
c  
c                - une onde P descendante (jcas=1) dans la couche ln
c                - une onde S descendante (jcas=1) dans la couche ln

      su1(1)=1.
      su1(2)=0.
      su2(1)=0.
      su2(2)=1.
      call reflect4(cfwave,jcas)

      return
      end
c******************************************************************************
c                                                          AXITRA Version 1.0 *
c                         subroutine REFLECT1                                 *
c                                                                             *
c               Calcul des coefficients de reflexion/transmission             *
c               Matrice de Reflexion/Transmission et Dephasage             *
c       (Les coefficients de reflexion/transmission utilisent les memes       *
c            termes intermediaires que Aki-Richards p149, MAIS :              *
c            Aki utilise la convention inverse pour la TF (exp(-iwt)),        *
c        et travaille avec le parametre de rai et les angles d'incidences)    *
c                                                                             *
c      Le potentiel PSI utilise pour l'onde SV est defini par :               *
c                  u = rot ( rot (PSI) )                                      *
c      i.e. un terme de derivation supplementaire par rapport a la convention *
c      habituelle : u= rot (PSI)                                              *
c                                                                             *
c   On deduit les coefficients de REF/TRANS de ceux definis par la convention *
c      classique en divisant le potentiel PSI par 1./ai/cwx = coef             *
c ---------FAIT LE 03/10/89 (PYB) --------------------------------------------*
c                                                                             *
c       Ordre de stockage :                                                   *
c                              pp=(1,1)   sp=(1,2)                            *
c                              ps=(2,1)   ss=(2,2)                            *
c******************************************************************************


      subroutine reflect1(jcas)

      implicit real   (a-b,d-h,o-z)
      implicit complex    (c)
      integer nlay
      parameter (nlay=50)
      common /dim1a/ ai,pi,pi2,omega,omega2,cwx,cwx2
      common /dim1e/ nc,hc(nlay),cvp(nlay),cvs(nlay),rho(nlay)


      common /dim2a/ cka(nlay),ckb(nlay),cka2(nlay),ckb2(nlay),
     &               cnu(nlay),cgam(nlay)
      common /dim2c/ rd(nlay,2,2),ru(nlay,2,2),td(nlay,2,2),
     &               tu(nlay,2,2),rdsh(nlay),rush(nlay),
     &               tdsh(nlay),tush(nlay),me1(nlay),me2(nlay)
      common /dim2d/ nt(nlay,2,2),mt(nlay,2,2),ntsh(nlay),mtsh(nlay)
      common /dim2e/ fdo(nlay,2,2),fup(nlay,2,2),fupsh(nlay),fdosh(nlay)

      complex      egam,enu,pu,pd,push,pdsh,ftup,ftdo,ftupsh,ftdosh
      complex     me1,me2,nt,mt,ntsh,mtsh,fdo,fup,fdosh,fupsh,
     &            u,ru,rd,tu,td,rdsh,rush,tush,tdsh
      complex    ai,omega,omega2,cwx,cwx2,cvp,cvs

c Coefficient pour la convention sur PSI (coef) et sur la TF (aki=-1.)
      aki=-1.
      
c               Coefficient a la surface libre
      if(jcas.eq.0) then
        cf1=(ckb2(1)-2.*cwx2)
        cf2=cf1*cf1
        cf3=4.*cnu(1)*cwx2*cgam(1)
        cdd=cf2+cf3
c       write(6,*) cdd
  
        ru(1,1,1)=(-cf2+cf3)/cdd
        ru(1,2,1)=4.*cwx*cnu(1)*cf1/cdd*aki
        ru(1,2,2)=(cf2-cf3)/cdd*aki
        ru(1,1,2)=4.*cwx*cgam(1)*cf1/cdd                                  
        tu(1,1,1)=0.
        tu(1,1,2)=0.
        tu(1,2,1)=0.
        tu(1,2,2)=0.
        rush(1)=1.
        tush(1)=0.

                    else
c            Coefficient pour espace infini
        ru(1,1,1)=0.
        ru(1,2,1)=0.
        ru(1,2,2)=0.
        ru(1,1,2)=0.
        tu(1,1,1)=1.
        tu(1,1,2)=0.
        tu(1,2,1)=0.
        tu(1,2,2)=1.
        rush(1)=0.
        tush(1)=1.
                     end if

c               Coefficients aux interfaces entre couches

c     write(6,*) 'boucle 24 de reflect1',nc
      do 24 ic=2,nc
c     write(6,*) ic,rho(ic-1),cabs(cvs(ic-1)),cabs(cvp(ic-1))
c     write(6,*) ic,rho(ic),cabs(cvs(ic)),cabs(cvp(ic))

      cb1=cwx2/ckb2(ic-1)
      cb2=cwx2/ckb2(ic)
      ca1d=rho(ic-1)*(1.-2.*cb1)
      ca2d=rho(ic)*(1.-2.*cb2)
c     write(6,*) cabs(cb1),cabs(cb2),cabs(ca1d),cabs(ca2d)
      ca=ca2d-ca1d
      cb=ca2d+2.*rho(ic-1)*cb1
      cc=ca1d+2.*rho(ic)*cb2
      cd=2.*(rho(ic)/ckb2(ic)-rho(ic-1)/ckb2(ic-1))
c     write(6,*) cabs(ca),cabs(cb),cabs(cc),cabs(cd)
      ce=cb*cnu(ic-1)+cc*cnu(ic)
      cf=cb*cgam(ic-1)+cc*cgam(ic)
      cg=ca-cd*cnu(ic-1)*cgam(ic)
      ch=ca-cd*cnu(ic)*cgam(ic-1)
c     write(6,*) cabs(ce),cabs(cf),cabs(cg),cabs(ch)
      cdd=ce*cf+cg*ch*cwx2
c     write(6,*) ic,cdd

      rd(ic,1,1)= (cf*(cb*cnu(ic-1)-cc*cnu(ic))-
     &            ch*cwx2*(ca+cd*cnu(ic-1)*cgam(ic)))/cdd
      rd(ic,1,2)=-2.*cwx*cgam(ic-1)*
     &            (ca*cb+cc*cd*cnu(ic)*cgam(ic))/cdd*aki
      rd(ic,2,2)=-(ce*(cb*cgam(ic-1)-cc*cgam(ic))-
     &            cg*cwx2*(ca+cd*cnu(ic)*cgam(ic-1)))/cdd*aki
      rd(ic,2,1)=-2.*cwx*cnu(ic-1)*
     &            (ca*cb+cc*cd*cnu(ic)*cgam(ic))/cdd
      td(ic,1,1)= 2.*rho(ic-1)*cnu(ic-1)*cf/cdd
      td(ic,1,2)=-2.*rho(ic-1)*cgam(ic-1)*cg*cwx/cdd*aki
      td(ic,2,2)= 2.*rho(ic-1)*cgam(ic-1)*ce/cdd
      td(ic,2,1)= 2.*rho(ic-1)*cnu(ic-1)*ch*cwx/cdd*aki

      ru(ic,1,1)=-(cf*(cb*cnu(ic-1)-cc*cnu(ic))+
     &            cg*cwx2*(ca+cd*cnu(ic)*cgam(ic-1)))/cdd
      ru(ic,1,2)= 2.*cwx*cgam(ic)*
     &            (ca*cc+cb*cd*cnu(ic-1)*cgam(ic-1))/cdd
      ru(ic,2,2)= (ce*(cb*cgam(ic-1)-cc*cgam(ic))+
     &            ch*cwx2*(ca+cd*cnu(ic-1)*cgam(ic)))/cdd*aki
      ru(ic,2,1)= 2.*cwx*cnu(ic)*
     &            (ca*cc+cb*cd*cnu(ic-1)*cgam(ic-1))/cdd*aki
      tu(ic,1,1)= 2.*rho(ic)*cnu(ic)*cf/cdd
      tu(ic,1,2)= 2.*rho(ic)*cgam(ic)*ch*cwx/cdd
      tu(ic,2,2)= 2.*rho(ic)*cgam(ic)*ce/cdd
      tu(ic,2,1)=-2.*rho(ic)*cnu(ic)*cg*cwx/cdd

      me1(ic-1)=exp(-ai*cnu(ic-1)*hc(ic-1))
      me2(ic-1)=exp(-ai*cgam(ic-1)*hc(ic-1))

      cs1=rho(ic-1)/ckb2(ic-1)*cgam(ic-1)
      cs2=rho(ic)/ckb2(ic)*cgam(ic)
      cdelt=cs1+cs2

      rush(ic)=(cs2-cs1)/cdelt
      rdsh(ic)=-rush(ic)
      tush(ic)=2.*cs2/cdelt
      tdsh(ic)=2.*cs1/cdelt

 24   continue

      return
      end
c*******************************************************************************
c*                                                          AXITRA Version 1.0 *
c*                         subroutine REFLECT2                                 *
c*                                                                             *
c*       Calcul des matrices de reflectivite mt,mb ou nt,nb dans chaque couche *
c*         (rapport des potentiels montant/descendant ou descendant/montant)   *
c*       Le suffixe t ou b precise si la matrice est donnee au sommet (top)    *
c*       ou au bas (bottom) de la couche.                                      *
c*       fup et fdo sont des matrices intermediaires utilisees dans le calcul  *
c*       des potentiels.                                                       *
c*       Ordre de stockage :                                                   *
c*                    pp=(1,1)   sp=(1,2)                                      *
c*                    ps=(2,1)   ss=(2,2)                                      *
c*******************************************************************************

      subroutine reflect2

      implicit real   (a-b,d-h,o-z)
      implicit complex    (c)
      integer nlay
      parameter (nlay=50)
      complex    ai,omega,omega2,cwx,cwx2
      common /dim1a/ ai,pi,pi2,omega,omega2,cwx,cwx2
      common /dim1e/ nc,hc(nlay),cvp(nlay),cvs(nlay),rho(nlay)

      complex     me1,me2,nt,mt,ntsh,mtsh,fdo,fup,fdosh,fupsh,
     &            u,ru,rd,tu,td,rdsh,rush,tush,tdsh


      common /dim2a/ cka(nlay),ckb(nlay),cka2(nlay),ckb2(nlay),
     &               cnu(nlay),cgam(nlay)
      common /dim2c/ rd(nlay,2,2),ru(nlay,2,2),td(nlay,2,2),
     &               tu(nlay,2,2),rdsh(nlay),rush(nlay),
     &               tdsh(nlay),tush(nlay),me1(nlay),me2(nlay)
      common /dim2d/ nt(nlay,2,2),mt(nlay,2,2),ntsh(nlay),mtsh(nlay)
      common /dim2e/ fdo(nlay,2,2),fup(nlay,2,2),fupsh(nlay),fdosh(nlay)

      complex      egam,enu,pu,pd,push,pdsh,ftup,ftdo,ftupsh,ftdosh

      complex    nb(2,2),mb(2,2),nbsh,mbsh

c
c           Calcul pour les couches au dessus de la source
c

      nt(1,1,1)=ru(1,1,1)
      nt(1,1,2)=ru(1,1,2)
      nt(1,2,1)=ru(1,2,1)
      nt(1,2,2)=ru(1,2,2)
      ntsh(1)=rush(1)

      do 10 ic=1,nc-1

      nb(1,1)=me1(ic)*me1(ic)*nt(ic,1,1)
      nb(1,2)=me1(ic)*me2(ic)*nt(ic,1,2)
      nb(2,1)=me2(ic)*me1(ic)*nt(ic,2,1)
      nb(2,2)=me2(ic)*me2(ic)*nt(ic,2,2)
      nbsh=me2(ic)*me2(ic)*ntsh(ic)
      
      ca1=1.-(rd(ic+1,1,1)*nb(1,1)+rd(ic+1,1,2)*nb(2,1))
      ca2=-(rd(ic+1,1,1)*nb(1,2)+rd(ic+1,1,2)*nb(2,2))
      ca3=-(rd(ic+1,2,1)*nb(1,1)+rd(ic+1,2,2)*nb(2,1))
      ca4=1.-(rd(ic+1,2,1)*nb(1,2)+rd(ic+1,2,2)*nb(2,2))
      cadet=ca1*ca4-ca2*ca3
      cash=1./(1.-rdsh(ic+1)*nbsh)

      cb1=td(ic+1,1,1)*nb(1,1)+td(ic+1,1,2)*nb(2,1)
      cb2=td(ic+1,1,1)*nb(1,2)+td(ic+1,1,2)*nb(2,2)
      cb3=td(ic+1,2,1)*nb(1,1)+td(ic+1,2,2)*nb(2,1)
      cb4=td(ic+1,2,1)*nb(1,2)+td(ic+1,2,2)*nb(2,2)
      cbsh=tdsh(ic+1)*nbsh

      cc1=(ca4*tu(ic+1,1,1)-ca2*tu(ic+1,2,1))/cadet
      cc2=(ca4*tu(ic+1,1,2)-ca2*tu(ic+1,2,2))/cadet
      cc3=(-ca3*tu(ic+1,1,1)+ca1*tu(ic+1,2,1))/cadet 
      cc4=(-ca3*tu(ic+1,1,2)+ca1*tu(ic+1,2,2))/cadet
      ccsh=cash*tush(ic+1)

      nt(ic+1,1,1)=ru(ic+1,1,1)+cb1*cc1+cb2*cc3
      nt(ic+1,1,2)=ru(ic+1,1,2)+cb1*cc2+cb2*cc4
      nt(ic+1,2,1)=ru(ic+1,2,1)+cb3*cc1+cb4*cc3
      nt(ic+1,2,2)=ru(ic+1,2,2)+cb3*cc2+cb4*cc4
      ntsh(ic+1)=rush(ic+1)+cbsh*ccsh
 
      fup(ic,1,1)=cc1*me1(ic)
      fup(ic,1,2)=cc2*me1(ic)
      fup(ic,2,1)=cc3*me2(ic)
      fup(ic,2,2)=cc4*me2(ic)
      fupsh(ic)=ccsh*me2(ic)
  
 10   continue
c
c            Calcul pour les couches au dessous de la source
c
      
      mt(nc,1,1)=0.
      mt(nc,1,2)=0.
      mt(nc,2,1)=0.
      mt(nc,2,2)=0.
      mtsh(nc)=0.

      do 20 ic=nc-1,1,-1

      ca1=1.-(ru(ic+1,1,1)*mt(ic+1,1,1)+ru(ic+1,1,2)*mt(ic+1,2,1))
      ca2=-(ru(ic+1,1,1)*mt(ic+1,1,2)+ru(ic+1,1,2)*mt(ic+1,2,2))
      ca3=-(ru(ic+1,2,1)*mt(ic+1,1,1)+ru(ic+1,2,2)*mt(ic+1,2,1))
      ca4=1.-(ru(ic+1,2,1)*mt(ic+1,1,2)+ru(ic+1,2,2)*mt(ic+1,2,2))
      cadet=ca1*ca4-ca2*ca3
      cash=1./(1.-rush(ic+1)*mtsh(ic+1))
 
      cb1=tu(ic+1,1,1)*mt(ic+1,1,1)+tu(ic+1,1,2)*mt(ic+1,2,1)
      cb2=tu(ic+1,1,1)*mt(ic+1,1,2)+tu(ic+1,1,2)*mt(ic+1,2,2)
      cb3=tu(ic+1,2,1)*mt(ic+1,1,1)+tu(ic+1,2,2)*mt(ic+1,2,1)
      cb4=tu(ic+1,2,1)*mt(ic+1,1,2)+tu(ic+1,2,2)*mt(ic+1,2,2)
      cbsh=tush(ic+1)*mtsh(ic+1)

      cc1=(ca4*td(ic+1,1,1)-ca2*td(ic+1,2,1))/cadet
      cc2=(ca4*td(ic+1,1,2)-ca2*td(ic+1,2,2))/cadet
      cc3=(-ca3*td(ic+1,1,1)+ca1*td(ic+1,2,1))/cadet 
      cc4=(-ca3*td(ic+1,1,2)+ca1*td(ic+1,2,2))/cadet
      ccsh=cash*tdsh(ic+1)

      mb(1,1)=rd(ic+1,1,1)+cb1*cc1+cb2*cc3
      mb(1,2)=rd(ic+1,1,2)+cb1*cc2+cb2*cc4
      mb(2,1)=rd(ic+1,2,1)+cb3*cc1+cb4*cc3
      mb(2,2)=rd(ic+1,2,2)+cb3*cc2+cb4*cc4
      mbsh=rdsh(ic+1)+cbsh*ccsh

      mt(ic,1,1)=me1(ic)*me1(ic)*mb(1,1)
      mt(ic,1,2)=me1(ic)*me2(ic)*mb(1,2)
      mt(ic,2,1)=me2(ic)*me1(ic)*mb(2,1)
      mt(ic,2,2)=me2(ic)*me2(ic)*mb(2,2)
      mtsh(ic)=me2(ic)*me2(ic)*mbsh

      fdo(ic+1,1,1)=cc1*me1(ic)
      fdo(ic+1,1,2)=cc2*me2(ic)
      fdo(ic+1,2,1)=cc3*me1(ic)
      fdo(ic+1,2,2)=cc4*me2(ic)
      fdosh(ic+1)=ccsh*me2(ic)

 20   continue

      return
      end

      subroutine reflect4(cfwave,jcas)

      implicit real   (a-b,d-h,o-z)
      implicit complex    (c)
      integer nlay
      parameter (nlay=50)
      parameter (nlay4=4*nlay)
      complex    ai,omega,omega2,cwx,cwx2,cfwave(nlay4,3)

      common /dim1a/ ai,pi,pi2,omega,omega2,cwx,cwx2
      common /dim1e/ nc,hc(nlay),cvp(nlay),cvs(nlay),rho(nlay)

      complex     me1,me2,nt,mt,ntsh,mtsh,fdo,fup,fdosh,fupsh,
     &            u,ru,rd,tu,td,rdsh,rush,tush,tdsh


      common /dim2a/ cka(nlay),ckb(nlay),cka2(nlay),ckb2(nlay),
     &               cnu(nlay),cgam(nlay)
      common /dim2c/ rd(nlay,2,2),ru(nlay,2,2),td(nlay,2,2),
     &               tu(nlay,2,2),rdsh(nlay),rush(nlay),
     &               tdsh(nlay),tush(nlay),me1(nlay),me2(nlay)
      common /dim2d/ nt(nlay,2,2),mt(nlay,2,2),ntsh(nlay),mtsh(nlay)
      common /dim2e/ fdo(nlay,2,2),fup(nlay,2,2),fupsh(nlay),fdosh(nlay)

      complex      egam,enu,pu,pd,push,pdsh,ftup,ftdo,ftupsh,ftdosh
      
      dimension pu(nlay,2,2),pd(nlay,2,2),push(nlay),pdsh(nlay),
     &          ftup(nlay,2,2),ftdo(nlay,2,2),ftupsh(nlay),ftdosh(nlay)

c      
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
c  Matrices de passage des vecteurs potentiels dans la 
c  couche source aux vecteurs potentiel dans chaque couche
c
c                    [ftup] et [ftdo]
c       
c               ------------------------
c
c  Les vecteurs potentiels pu() et pd() sont obtenus a
c  partir des vecteurs potentiels su() et sd() dans la 
c  couche origine par:
c
c  Couche (n) au dessus de la couche source (jcas=0):
c
c   pu(n) = [fup(n)]*[fup(n+1)]* *[fup(nc-1] . su
c
c   d'ou l'on tire pd(n) par  pd(n) = [nt(n)] . pu(n)
c
c  Couche (m) au dessous de la couche source (jcas=1):
c
c   pd(m) = [fdo(m)]*[fdo(m-1)]* *[fdo(2)] . sd
c
c   d'ou l'on tire pu(m) par  pu(m) = [mt(m)] . pd(m)
c
c                -------------------------
c   On pose :
c
c        [ftup(n)] = [fup(n)]*...*[fup(isc-1)]*[tud]
c
c        [ftdo(m)] = [fdo(m)]*...*[fdo(isc+1)]*[tdu]
c
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

       if(jcas.eq.1) go to 1
c            Cas jcas = 0: reflexions surface libre
c
      ftup(nc,1,1)=1.
      ftup(nc,1,2)=0.
      ftup(nc,2,1)=0.
      ftup(nc,2,2)=1.
      ftupsh(nc)=1.

      do 10 ic=nc-1,1,-1

      ftup(ic,1,1)=fup(ic,1,1)*ftup(ic+1,1,1)+fup(ic,1,2)*ftup(ic+1,2,1)
      ftup(ic,1,2)=fup(ic,1,1)*ftup(ic+1,1,2)+fup(ic,1,2)*ftup(ic+1,2,2)
      ftup(ic,2,1)=fup(ic,2,1)*ftup(ic+1,1,1)+fup(ic,2,2)*ftup(ic+1,2,1)
      ftup(ic,2,2)=fup(ic,2,1)*ftup(ic+1,1,2)+fup(ic,2,2)*ftup(ic+1,2,2)
      ftupsh(ic)=fupsh(ic)*ftupsh(ic+1)

 10   continue
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
c  Vecteurs potentiel montant (pu) et descendant (pd),
c  dans chaque couche recepteur, pour les 6 sources elementaires
c
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

c            Recepteurs au dessus de la source

      do 20 ic=1,nc

      ic1=4*ic-3
      ic2=ic1+1
      ic3=ic2+1
      ic4=ic3+1
      pu(ic,1,1)=ftup(ic,1,1)
      pu(ic,2,1)=ftup(ic,2,1)
      pd(ic,1,1)=nt(ic,1,1)*pu(ic,1,1)+nt(ic,1,2)*pu(ic,2,1)
      pd(ic,2,1)=nt(ic,2,1)*pu(ic,1,1)+nt(ic,2,2)*pu(ic,2,1)
        cfwave(ic1,1)=pu(ic,1,1)
        cfwave(ic2,1)=pd(ic,1,1)
        cfwave(ic3,1)=pu(ic,2,1)
        cfwave(ic4,1)=pd(ic,2,1)


      pu(ic,1,2)=                    ftup(ic,1,2)
      pu(ic,2,2)=                    ftup(ic,2,2)
      pd(ic,1,2)=nt(ic,1,1)*pu(ic,1,2)+nt(ic,1,2)*pu(ic,2,2) 
      pd(ic,2,2)=nt(ic,2,1)*pu(ic,1,2)+nt(ic,2,2)*pu(ic,2,2)
        cfwave(ic1,2)=pu(ic,1,2)
        cfwave(ic2,2)=pd(ic,1,2)
        cfwave(ic3,2)=pu(ic,2,2)
        cfwave(ic4,2)=pd(ic,2,2)

      icsh1=2*ic-1
      icsh2=icsh1+1
      push(ic)=ftupsh(ic)
      pdsh(ic)=ntsh(ic)*push(ic)
        cfwave(icsh1,3)=push(ic)
        cfwave(icsh2,3)=pdsh(ic)

 20   continue
      return

1      continue

c            Cas jcas = 1 : pas d'onde montante incidente
c
      ftdo(1,1,1)=1.
      ftdo(1,1,2)=0.
      ftdo(1,2,1)=0.
      ftdo(1,2,2)=1.
      ftdosh(1)=1.

      do 11 ic=2,nc

      ftdo(ic,1,1)=fdo(ic,1,1)*ftdo(ic-1,1,1)+fdo(ic,1,2)*ftdo(ic-1,2,1)
      ftdo(ic,1,2)=fdo(ic,1,1)*ftdo(ic-1,1,2)+fdo(ic,1,2)*ftdo(ic-1,2,2)
      ftdo(ic,2,1)=fdo(ic,2,1)*ftdo(ic-1,1,1)+fdo(ic,2,2)*ftdo(ic-1,2,1)
      ftdo(ic,2,2)=fdo(ic,2,1)*ftdo(ic-1,1,2)+fdo(ic,2,2)*ftdo(ic-1,2,2)
      ftdosh(ic)=fdosh(ic)*ftdosh(ic-1)

 11   continue


      do 21 ic=1,nc
 
      ic1=4*ic-3
      ic2=ic1+1
      ic3=ic2+1
      ic4=ic3+1
      pd(ic,1,1)=ftdo(ic,1,1)
      pd(ic,2,1)=ftdo(ic,2,1)
      pu(ic,1,1)=mt(ic,1,1)*pd(ic,1,1)+mt(ic,1,2)*pd(ic,2,1)
      pu(ic,2,1)=mt(ic,2,1)*pd(ic,1,1)+mt(ic,2,2)*pd(ic,2,1)
        cfwave(ic1,1)=pu(ic,1,1)
        cfwave(ic2,1)=pd(ic,1,1)
        cfwave(ic3,1)=pu(ic,2,1)
        cfwave(ic4,1)=pd(ic,2,1)
 
      pd(ic,1,2)=                    ftdo(ic,1,2)
      pd(ic,2,2)=                    ftdo(ic,2,2)
      pu(ic,1,2)=mt(ic,1,1)*pd(ic,1,2)+mt(ic,1,2)*pd(ic,2,2)
      pu(ic,2,2)=mt(ic,2,1)*pd(ic,1,2)+mt(ic,2,2)*pd(ic,2,2)
        cfwave(ic1,2)=pu(ic,1,2)
        cfwave(ic2,2)=pd(ic,1,2)
        cfwave(ic3,2)=pu(ic,2,2)
        cfwave(ic4,2)=pd(ic,2,2)
 
      icsh1=2*ic-1
      icsh2=icsh1+1
      pdsh(ic)=ftdosh(ic)
      push(ic)=mtsh(ic)*pdsh(ic)
        cfwave(icsh1,3)=push(ic)
        cfwave(icsh2,3)=pdsh(ic)
 
 21   continue

      return
      end
c
      function longcar(mot)
      character*(*) mot
      do 1 l=len(mot),1,-1
        if(mot(l:l).ne.' ') go to 2
1       continue
2     longcar=l
      return
      end

      subroutine four1(data,n,isign)
      dimension data(*)
      ip0=2
      ip3=ip0*n
      i3rev=1
      do 50 i3=1,ip3,ip0
      if(i3-i3rev) 10,20,20
10    tempr=data(i3)
      tempi=data(i3+1)
      data(i3)=data(i3rev)
      data(i3+1)=data(i3rev+1)
      data(i3rev)=tempr
      data(i3rev+1)=tempi
20    ip1=ip3/2
30    if(i3rev-ip1) 50,50,40
40    i3rev=i3rev-ip1
      ip1=ip1/2
      if(ip1-ip0) 50,30,30
50    i3rev=i3rev+ip1
      ip1=ip0
60    if(ip1-ip3) 70,100,100
70    ip2=ip1*2
      theta=6.2831853
      theta=theta/float(isign*ip2/ip0)
      sinth=sin(theta/2.0)
      wstpr=-2.0*sinth*sinth
      wstpi=sin(theta)
      wr=1.
      wi=0.
      do 90 i1=1,ip1,ip0
      do 80 i3=i1,ip3,ip2
      i2a=i3
      i2b=i2a+ip1
      tempr=wr*data(i2b)-wi*data(i2b+1)
      tempi=wr*data(i2b+1) + wi*data(i2b)
      data(i2b)=data(i2a)-tempr
      data(i2b+1)=data(i2a+1)-tempi
      data(i2a)=data(i2a)+tempr
80    data(i2a+1)=data(i2a+1)+tempi
      tempr=wr
      wr=wr*wstpr-wi*wstpi + wr
90    wi=wi*wstpr+tempr*wstpi + wi
      ip1=ip2
      go to 60
100   return
      end
      subroutine rcft(sig,sp,n,isign)
      real sig(*)
      common/four0/y(65536)
      complex sp(*)
      if(n.gt.32768) go to 100
      nf1=n/2+1
      do 1 i=1,n
      j=i+i
      j1=j-1
      y(j1)=sig(i)
1     y(j)=0.
      call four1(y,n,isign)
      do 2 i=1,nf1
      j=i+i
      j1=j-1
2     sp(i)=cmplx(y(j1),y(j))
      return
c *************************************************************
100   write(6,1000)  n
1000  format(1x,'more time domain points (',i5,
     1 ') than allowed in rcft (32768)')
      stop 100
c *************************************************************
      end
      subroutine crft(sp,sig,n,isign)
      dimension sig(*)
      common/four0/y(65536)
      complex sp(*)
      if(n.gt.32768) go to 100
      nf1=n/2+1
      nn4=n+n+4
      do 1 i=1,nf1
      j=i+i
      j1=j-1
      jj=nn4-j
      jj1=jj-1
      y(j1)=real(sp(i))
      y(j)=aimag(sp(i))
      y(jj1)=y(j1)
1     y(jj)=-y(j)
      y(2)=0.
      y(n+2)=0.
      call four1(y,n,isign)
      do 2 i=1,n
      j1=i+i-1
2     sig(i)=y(j1)
      return
c *************************************************************
100   write(6,1000) n
1000  format(1x,'more time domain points (',i5,
     1 ') than allowed in crft (32768)')
      stop 101
c *************************************************************
      end
c
      subroutine readr_ascii1(sigfile,sig,nsig,t0,dt)
c
c      Reads a time history file 'sigfile' with nsig (maximum ntmax) values, 
c        evenly spaced with sampling dt, starting at initial time t0
c
      parameter (ntmax=8192)
      character*40 sigfile
      real sig(ntmax),t0,dt
c
      open(50,file=sigfile)
      read(50,*) nsig,t0,dt
      do i=1,nsig
        read(50,*) sig(i)
        enddo
      close(50)
c
      return
      end
c
      subroutine writer_ascii1(sigfile,sig,nsig,x0,dx)
c
c     Writes a file 'sigfile' consisting of nsig (maximum ntmax) REAL values, 
c        evenly spaced with sampling dx, starting at initial point x0
c
      parameter (ntmax=8192)
      character*40 sigfile
      real sig(ntmax),x0,dx
c
      open(60,file=sigfile)
      write(60,6000) nsig,x0,dx
      do i=1,nsig
        write(60,6001) sig(i)
        enddo
      close(60)
c
6000  format(i10,2e15.5)
6001  format(e15.5)
c
      return
      end
c
c
      subroutine writer_ascii2(sigfile,x,sig,nsig)
c
c     Writes a file 'sigfile' consisting of nsig (maximum ntmax) REAL values,
c      unevenly spaced 
c
      parameter (ntmax=8192)
      character*40 sigfile
      real x(ntmax),sig(ntmax)
c
      open(60,file=sigfile)
      write(60,6000) nsig
      do i=1,nsig
        write(60,6002) x(i),sig(i)
        enddo
      close(60)
c
6000  format(i10,2e15.5)
6001  format(e15.5)
6002  format(2e15.5)
c
      return
      end
c

      subroutine writec_ascii1(sigfile,csig,nsig,x0,dx)
c
c     Writes a file 'sigfile' consisting of nsig (maximum ntmax) COMPLEX values,
c        evenly spaced with sampling dx, starting at initial point x0
c
      parameter (ntmax=8192)
      character*40 sigfile
      complex csig(ntmax)
      real x0,dx
c
      open(70,file=sigfile)
      write(70,7000) nsig,x0,dx
      do i=1,nsig
        write(70,7001) csig(i),cabs(csig(i))
        enddo
      close(70)
c
7000  format(i10,2e15.5)
7001  format(3e15.5)
c
      return
      end
c
      subroutine pcno3 (dmpng,nprds,prds,n,ga,fs,sd,sv,sa,ttsd,ttsv,
     &  ttsa,del,lulog,ttyout)
c
c         compute the response of a single-degree of freedom
c       oscillator for a given value of damping, for each of the nprds
c       periods given prds.
c                                                last mod.: 3/16/83, afs
      parameter(ntmax=8192)
      parameter(npmax=201)
      real prds(npmax),ga(ntmax)
      real fs(npmax),sd(npmax),sv(npmax),sa(npmax),
     1     ttsd(npmax),ttsv(npmax),ttsa(npmax)
c
      common/ matrix /a(2,2),b(2,2),amd,td,amdl,tdl
      double precision rtime,timep
      real dw,w2,amax,vmax,dmax,x,xx,vertl,beb,
     &     bb7,sl,g,ty,tyd,tydd,delt,delp,dtplot,vend,dmpng,p,w,td,amd,
     &     tdl,amdl,
     &     ttdmax,ttvmax,ttamax
      integer l,ia,lsum,i,m,k,lp,llp,ttyout
      real savpt(4097)
      real   aaaa,aaa,aa,ae,bbbb,bbb,bb,be
      equivalence (a(2,2),aaaa),(a(2,1),aaa),(a(1,2),aa),(a(1,1),ae)
      equivalence (b(2,2),bbbb),(b(2,1),bbb),(b(1,2),bb),(b(1,1),be)
      dtplot=0.2
      lsum=0
      llp=npmax
c
      do 1000 k = 1,nprds
      p = prds(k)
      w = 6.283185307179586d0/p
c
c      ****** choice of interval of integration ******
c
      delp = p/10.
      l = del/delp + 1. - 1.e-05
      vertl = 1.0/l
      delt = del*vertl
c
c      ****** computation of matrices a and b ******
c
      call pcno4(dmpng,w,delt,a,b)
c
c      ****** initiation ******
c
      rtime = 0.
      timep = 0.
      amd = 0.0
      td = 1.0
      lp = 1
      x = 0.
      xx = 0.
      dmax = 0.
      vmax = 0.
      amax = 0.
      i = 1
      dw = -2.0*w*dmpng
      w2 = -w*w
c          note negatives.
      beb = -(be+bb)
      bb7 = -(bbb+bbbb)
      ia = 2.0*p/delt + 0.5
   7  continue
      m = 0
      gi = 0.

      if(i .le. n) gi = ga(i)
      gnxt = 0.
      if(i .lt. n) gnxt = ga(i+1)
      sl = (gnxt - gi)*vertl
c
  6   g = gi + sl*m
      ty = aa*xx - sl*bb + ae*x + beb*g
      tyd = aaaa*xx - sl*bbbb + aaa*x + bb7*g
      tydd = abs(dw*tyd + w2*ty)
c
c      ***   monitoring and saving the peak values
c
      if(lp .gt. llp) go to 112
      if(tyd*xx .gt. 0.) go to 112
      amdl = amd
      tdl = td
      amd = abs(x)
      td = rtime
c
c          interpolation -- one point every dtplot seconds.
c
  111 if(timep .ge. rtime) go to 112
      savpt(lp) = amdl + (amd-amdl)*(timep-tdl)/(rtime-tdl)
      lp = lp+1
      timep = dble(float(lp-1))*dtplot

      if(lp .le. llp) go to 111
  112 continue
c
c      ****** monitoring the max. values ******
c
      if(dmax .ge. abs(ty)) go to 14
         dmax = abs(ty)
         ttdmax = rtime
         if(dmax .le. 1.e+10) go to 14
            write(lulog,113) dmax
            if(lulog .ne. ttyout) write(ttyout,113) dmax
  113       format('* fatal err.  sd =',e11.3)
            write(lulog,114) p,rtime,sl,ga(n1),k,i,n1
  114       format(' p,rtime,sl,ga(n1) =',4e11.3,/,' k,i,n1 =',3i8)
            stop
   14 x = ty
      if(vmax .ge. abs(tyd)) go to 15
         vmax = abs(tyd)
         ttvmax = rtime
   15 xx = tyd
      if(amax .ge. tydd) go to 16
         amax = tydd
         ttamax = rtime
   16 m = m+1
      rtime = rtime + dble(delt)

      if(m .lt. l) go to 6
c
c      ****** test for end of integration ******
c
cc    if(mod(i,50) .eq. 1) type " acc. point",i," integrated."
      i = i+1
      if(i .eq. n) go to 18
         if(i .lt. n) go to 7
         if(i .lt. (n+ia)) go to 7
         go to 20
   18 vend = sqrt(xx*xx - w2*x*x)
   20 if(k .eq. 1) llp = lp -1
c         (only at the highest frequency)
      if((lp-1) .lt. llp) go to 7
      lsum = lsum+llp
      if(dmpng .lt. 1.0e-03) fs(k) = vend
      sd(k) = dmax
      sv(k) = vmax
      sa(k) = amax
      ttsd(k) = ttdmax
      ttsv(k) = ttvmax
      ttsa(k) = ttamax
1000  continue

      return
      end
c **********************************************************
        subroutine pcno4(d,w,delt,a,b)
c
c       subroutine for computing matrices a and b used
c               by pcno3
c
        dimension a(2,2),b(2,2)
        dw=d*w
        d2=d*d
        a0=exp(-dw*delt)
        a1=w*sqrt(1.-d2)
        ad1=a1*delt
        a2=sin(ad1)
        a3=cos(ad1)
        a7=1.0/(w*w)
        a4=(2.0*d2-1.0)*a7
        a5=d/w
        a6=2.0*a5*a7
        a8=1.0/a1
        a9=-(a1*a2+dw*a3)*a0
        a10=(a3-dw*a2*a8)*a0
        a11=a2*a8
        a12=a11*a0
        a13=a0*a3
        a14=a10*a4
        a15=a12*a4

        a16=a6*a13
        a17=a9*a6
        a(1,1)=a0*(dw*a11+a3)
        a(1,2)=a12
        a(2,1)=a10*dw+a9
        a(2,2)=a10
        dinv=1.0/delt
        b(1,1)=(-a15-a16+a6)*dinv-a12*a5-a7*a13
        b(1,2)=(a15+a16-a6)*dinv+a7
        b(2,1)=(-a14-a17-a7)*dinv-a10*a5-a9*a7
        b(2,2)=(a14+a17+a7)*dinv
c       type " frequency =",w,"    pcno4 called."
        return
        end
c
