subroutine tipsv(re,ratc,ratl,tlen,np,omegai,imin,imax, &
   nzone,vrmin,vrmax,rrho,vpv,vph,vsv,vsh,eta,qmu,qkappa, &
   r0,eqlat,eqlon,mt,nr,theta,phi,lat,lon,output,write_to_file,&
   outputu)
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!c  ************** tipsv.f ****************
!c Computation of PSV synthetic seismograms
!c in transversely isotropic for anisotropic PREM
!c using modified DSM operators & modified source representation.
!c Synthetics for shallow events can be computed.
!c                                                 2002.12  K.Kawai
!c -> f90 Kensuke Konishi 2020 May 5
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    use parameters
    implicit none
! ---------------------------<< constants >>---------------------------
! write to files?
    logical, intent(in) :: write_to_file
! ---------------------------<< variables >>---------------------------
! variable for the trial function
    integer nlayer(maxnzone)
    integer nslay,nllay
    integer inlayer,jnlayer,jnslay,jnllay
    integer l,m
    double precision ra(maxnlay+maxnzone+1),plm(3,0:3,maxnr)
    complex(dp) bvec(3,-2:2,maxnr)
! variable for the structure
    integer nzone,isl,ill,nsl,nll
    integer iphase(maxnzone),ndc,vnp
    double precision rmin,rmax
    double precision,intent(in):: vrmin(maxnzone),vrmax(maxnzone)
    double precision,intent(in):: rrho(4,maxnzone), vpv(4,maxnzone),vph(4,maxnzone)
    double precision,intent(in):: vsv(4,maxnzone),vsh(4,maxnzone),eta(4,maxnzone)
    double precision,intent(in):: qmu(maxnzone),qkappa(maxnzone)
    double precision vra(maxnlay+2*maxnzone+1)
    double precision rho(maxnlay+2*maxnzone+1)
    double precision kappa(maxnlay+2*maxnzone+1)
    double precision ecKx(maxnlay+2*maxnzone+1) !3*Kx=3A-4N
    double precision ecKy(maxnlay+2*maxnzone+1) !3*Ky=3F+2N
    double precision ecKz(maxnlay+2*maxnzone+1) !3*Kz=2F+C
    double precision mu(maxnlay+2*maxnzone+1)
    double precision ecL(maxnlay+2*maxnzone+1)
    double precision ecN(maxnlay+2*maxnzone+1)
    double precision rhoinv(maxnlay+2*maxnzone+1)
    double precision kappainv(maxnlay+2*maxnzone+1)
    complex(dp) coef1(maxnzone),coef2(maxnzone),coef(maxnzone)
! variable for the periodic range
    integer np,imin,imax
    double precision tlen,omega,omegai
    complex(dp) u(3,maxnr)
! variable for the source
    integer spn,ns
    double precision,intent(in):: r0,mt(3,3),eqlat,eqlon
    double precision:: spo,ecC0,ecF0,ecL0
    complex(dp) ya(4),yb(4),yc(4),yd(4)
! variable for the station
    integer,intent(in):: nr
    double precision,intent(in):: theta(maxnr),phi(maxnr)
    double precision,intent(in):: lat(maxnr),lon(maxnr)
!c variable for the matrix elements
    complex(dp) a0(4,2*(2*(maxnslay+1)+(maxnllay+1)+maxnzone))
    complex(dp) a1(4,2*(2*(maxnslay+1)+(maxnllay+1)+maxnzone))
    complex(dp) a2(4,2*(2*(maxnslay+1)+(maxnllay+1)+maxnzone))
    complex(dp) a(4,2*(maxnslay+1) + (maxnllay+1) )
    complex(dp) c(2, (maxnslay+1) + (maxnllay+1) )
    double precision t(8*maxnslay )
    double precision h1x(8*maxnslay ),h1y( 8*maxnslay ),h1z( 8*maxnslay )
    double precision h2L(8*maxnslay ),h2N( 8*maxnslay )
    double precision h3ax(8*maxnslay )
    double precision h3ay(8*maxnslay ),h3az( 8*maxnslay )
    double precision h4aL(8*maxnslay ),h4aN( 8*maxnslay )
    double precision h5ax(8*maxnslay ),h5ay( 8*maxnslay ),h5az( 8*maxnslay )
    double precision h6aL(8*maxnslay ),h6aN( 8*maxnslay )
    double precision h3x(8*maxnslay ),h3y( 8*maxnslay ),h3z( 8*maxnslay )
    double precision h4L(8*maxnslay ),h4N( 8*maxnslay )
    double precision h5x(8*maxnslay ),h5y( 8*maxnslay ),h5z( 8*maxnslay )
    double precision h6L(8*maxnslay ),h6N( 8*maxnslay )
    double precision h7x(8*maxnslay ),h7y( 8*maxnslay ),h7z( 8*maxnslay )
    double precision h8L(8*maxnslay ),h8N( 8*maxnslay )
    double precision h3mx(-2:1,2*(maxnslay+maxnzone) )
    double precision h3my(-2:1,2*(maxnslay+maxnzone) )
    double precision h3mz(-2:1,2*(maxnslay+maxnzone) )
    double precision h5mx(-1:2,2*(maxnslay+maxnzone) )
    double precision h5my(-1:2,2*(maxnslay+maxnzone) )
    double precision h5mz(-1:2,2*(maxnslay+maxnzone) )
    double precision h4m1L(-1:2,2*(maxnslay+maxnzone) )
    double precision h4m1N(-1:2,2*(maxnslay+maxnzone) )
    double precision h4m2L(-2:1,2*(maxnslay+maxnzone) )
    double precision h4m2N(-2:1,2*(maxnslay+maxnzone) )
    double precision h6m1L(-1:2,2*(maxnslay+maxnzone) )
    double precision h6m1N(-1:2,2*(maxnslay+maxnzone) )
    double precision h6m2L(-2:1,2*(maxnslay+maxnzone) )
    double precision h6m2N(-2:1,2*(maxnslay+maxnzone) )
    double precision p1(8*maxnllay ),p2( 8*maxnllay ),p3( 8*maxnllay )
    complex(dp) g(2*(maxnslay+1) + (maxnllay+1) )
    complex(dp) d((maxnslay+1) + (maxnllay+1) )
    !c variable for the file
    character*80 output(maxnr)
    !c variable for the stack point
    integer isp(maxnzone)
    integer issp(maxnzone)
    integer ilsp(maxnzone),jssp(maxnzone)
    integer jsp(maxnzone)
    integer ksp(maxnzone),lsp(maxnzone)
    integer isdr,jsdr,ildr
    ! variables for the gridding
    integer jjdr(maxnzone),kkdr(maxnzone)
    integer jdr,kdr
    double precision vmin(maxnzone),gridpar(maxnzone),dzpar(maxnzone)
    ! variables for l cut off
    complex(dp) tmpc(2*(maxnslay+1) + (maxnllay+1))
    integer sufzone,ismall,kc,lsuf,llog
    double precision maxamp,ratc,ratl,re
    ! variables for the numerical integration
    complex(dp) anum(4,4,10),bnum(4,4,10)
    ! other variables
    integer i,j,ii,nn,lda,ir,ier,itmp,jtmp,mtmp,kkdr0,nn0
    integer ll(12),lli(12),llj(12)
    double precision eps,work(8*maxnslay),l2,lsq
    complex(dp) z( 2*(maxnslay+1) + (maxnllay+1) )
    complex(dp) w( 2*(maxnslay+1) + (maxnllay+1) )
    complex(dp) cwork( 2*(16*maxnslay + 4*maxnllay) )
    integer ltmp(2),iimax

    data lda/ 4 /
    data eps/ -1.d0 /
    complex(dp), intent(out) :: outputu(3,nr,imin:imax)

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
! *************** Inputting and computing the parameters ***************
! --- inputting parameter ---
    ! --- computing the required parameters ---
    ! counting of the nsl and nll
    call calnl( nzone,vsv,iphase,nsl,nll )
    ! computing and checking the parameters
    rmin = vrmin(1)
    rmax = vrmax(nzone)
    ndc = nzone - 1

    if ( r0<rmin .or. r0>rmax ) stop 'Location of the source is improper.'

    iimax = imax

    if( (rmax-r0)<shallowdepth) then ! option for shallow events
        ! computing of the number and the location of grid points
        iimax = int(tlen * 2.d0)
        call calgrid( nzone,vrmin,vrmax,vpv,vsv,rmin,rmax,iimax,1,tlen, vmin,gridpar,dzpar )
        call calra(inlayer,jnlayer,jnslay,jnllay,dzpar,nzone,vrmin,vrmax,iphase,rmin,nslay,nllay,nlayer,ra,re )
        ! --- checking the parameter
        if ( inlayer > maxnlay ) stop 'The number of grid points is too large.'
        if ( nslay > maxnslay ) stop 'The number of the grid points in the solid is too large.'
        if ( nllay > maxnllay ) stop 'The number of the grid points in the liquid is too large.'
        if ( jnlayer > 2*maxnlay ) stop 'The number of the total grid points is too large.'
        if ( ( jnslay > 2*maxnslay ).or.( jnllay>2*maxnllay ) ) stop 'The number of the total grid points is too large.'
        ! computing the stack points
        call calsp(ndc,nsl,nll,iphase,nlayer,nllay,&
                isp,jsp,ksp,issp,ilsp,lsp,jssp,isdr,jsdr,ildr,jdr,kdr )
        ! computing the source location
        call calspo(vrmax,iphase,inlayer,r0,rmin,rmax,ra,isp,spo,spn )
        ! ******************* Computing the matrix elements *******************

    ! computing the structure grid points
    call calstg( nzone,rrho,vpv,vph,vsv,vsh,eta,nlayer,ra,rmax,&
                vnp,vra,rho,kappa,ecKx,ecKy,ecKz,mu,ecL,ecN,r0,spn,ecC0,ecF0,ecL0 )

    rhoinv(1:vnp)=1.d0/rho(1:vnp)
    kappainv(1:vnp)=1.d0/kappa(1:vnp)
    isl = 0
    ill = 0
    do i=1,ndc+1
        if ( iphase(i)==1 ) then
            isl = isl + 1
            itmp = isdr+issp(isl)
            call calmatc( nlayer(i),vnp,vra,rho,2,0,0,ra(isp(i)), t(itmp) )
            call caltl( nlayer(i),vnp,vra,rho,ra(isp(i)),work(itmp) )
            t(itmp:itmp+4*nlayer(i)-1)=(t(itmp:itmp+4*nlayer(i)-1)+work(itmp:itmp+4*nlayer(i)-1))/2d0
            call calmatc( nlayer(i),vnp,vra,ecKx,0,0,0,ra(isp(i)),h1x(itmp) )
            call calhl( nlayer(i),vnp,vra,ecKx,ra(isp(i)),work(itmp) )
            h1x(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h1x(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecKy,0,0,0,ra(isp(i)),h1y(itmp) )
            call calhl( nlayer(i),vnp,vra,ecKy,ra(isp(i)),work(itmp) )
            h1y(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h1y(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecKz,0,0,0,ra(isp(i)),h1z(itmp) )
            call calhl( nlayer(i),vnp,vra,ecKz,ra(isp(i)),work(itmp) )
            h1z(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h1z(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecL,0,0,0,ra(isp(i)),h2L(itmp) )
            call calhl( nlayer(i),vnp,vra,ecL,ra(isp(i)),work(itmp) )
            h2L(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h2L(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecN,0,0,0,ra(isp(i)),h2N(itmp) )
            call calhl( nlayer(i),vnp,vra,ecN,ra(isp(i)),work(itmp) )
            h2N(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h2N(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecKx,1,0,1,ra(isp(i)),h5ax(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKy,1,0,1,ra(isp(i)),h5ay(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKz,1,0,1,ra(isp(i)),h5az(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecL,1,0,1,ra(isp(i)),h6aL(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecN,1,0,1,ra(isp(i)),h6aN(itmp) )
            call mtrnp( nlayer(i),h5ax(itmp),h3ax(itmp) )
            call mtrnp( nlayer(i),h5ay(itmp),h3ay(itmp) )
            call mtrnp( nlayer(i),h5az(itmp),h3az(itmp) )
            call mtrnp( nlayer(i),h6aL(itmp),h4aL(itmp) )
            call mtrnp( nlayer(i),h6aN(itmp),h4aN(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKx,2,1,1,ra(isp(i)), h7x(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKy,2,1,1,ra(isp(i)), h7y(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKz,2,1,1,ra(isp(i)), h7z(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecL,2,1,1,ra(isp(i)), h8L(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecN,2,1,1,ra(isp(i)), h8N(itmp) )
        else
            ill = ill + 1
            itmp = ildr+ilsp(ill)
            call calmatc( nlayer(i),vnp,vra,rhoinv,2,1,1,ra(isp(i)),p1(itmp) )
            call calmatc( nlayer(i),vnp,vra,rhoinv,0,0,0,ra(isp(i)),p2(itmp) )
            call calhl( nlayer(i),vnp,vra,rhoinv,ra(isp(i)),work(itmp) )
            p2(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+p2(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,kappainv,2,0,0,ra(isp(i)),p3(itmp) )
            call caltl( nlayer(i),vnp,vra,kappainv,ra(isp(i)),work(itmp) )
            p3(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+p3(itmp:itmp+4*nlayer(i)-1))/2
        endif
    enddo
 !  Computing the modified operator of the 1st derivative
    call caltstg( nzone,rrho,vpv,vph,vsv,vsh,eta,nlayer,ra,rmax,vra,kappa,ecKx,ecKy,ecKz,mu,ecL,ecN )
    isl = 0
    do i=1,ndc+1
        if ( iphase(i)==1 ) then
            isl = isl + 1
            itmp = isdr+issp(isl)
            jtmp = isp(i)+i-1
            call calh5( nlayer(i),vra(jtmp),ecKx(jtmp),ra(isp(i)),work(itmp) )
            h5x(itmp:itmp+4*nlayer(i)-1)= h5ax(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
            call calh5( nlayer(i),vra(jtmp),ecKy(jtmp),ra(isp(i)),work(itmp) )
            h5y(itmp:itmp+4*nlayer(i)-1)= h5ay(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
            call calh5( nlayer(i),vra(jtmp),ecKz(jtmp),ra(isp(i)),work(itmp) )
            h5z(itmp:itmp+4*nlayer(i)-1)= h5az(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
            call calh5( nlayer(i),vra(jtmp),ecL(jtmp),ra(isp(i)),work(itmp) )
            h6L(itmp:itmp+4*nlayer(i)-1)= h6aL(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
            call calh5( nlayer(i),vra(jtmp),ecN(jtmp),ra(isp(i)),work(itmp) )
            h6N(itmp:itmp+4*nlayer(i)-1)= h6aN(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
            call mtrnp( nlayer(i),h5x(itmp),h3x(itmp) )
            call mtrnp( nlayer(i),h5y(itmp),h3y(itmp) )
            call mtrnp( nlayer(i),h5z(itmp),h3z(itmp) )
            call mtrnp( nlayer(i),h6L(itmp),h4L(itmp) )
            call mtrnp( nlayer(i),h6N(itmp),h4N(itmp) )
            itmp = jsdr+jssp(isl)
            call calhm1( nlayer(i),vra(jtmp),ecKx(jtmp),ra(isp(i)),h5mx(-1,itmp) )
            call calhm1( nlayer(i),vra(jtmp),ecKy(jtmp),ra(isp(i)),h5my(-1,itmp) )
            call calhm1( nlayer(i),vra(jtmp),ecKz(jtmp),ra(isp(i)),h5mz(-1,itmp) )
            call calhm1( nlayer(i),vra(jtmp),ecL(jtmp),ra(isp(i)),h6m1L(-1,itmp) )
            call calhm1( nlayer(i),vra(jtmp),ecN(jtmp),ra(isp(i)),h6m1N(-1,itmp) )
            call calhm2( nlayer(i),vra(jtmp),ecL(jtmp),ra(isp(i)),h6m2L(-2,itmp) )
            call calhm2( nlayer(i),vra(jtmp),ecN(jtmp),ra(isp(i)),h6m2N(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h5mx(-1,itmp),h3mx(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h5my(-1,itmp),h3my(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h5mz(-1,itmp),h3mz(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h6m1L(-1,itmp),h4m2L(-2,itmp))
            call mtrnp2( nlayer(i),1,2,h6m1N(-1,itmp),h4m2N(-2,itmp))
            call mtrnp2( nlayer(i),2,1,h6m2L(-2,itmp),h4m1L(-1,itmp))
            call mtrnp2( nlayer(i),2,1,h6m2N(-2,itmp),h4m1N(-1,itmp))
        endif
    enddo

    do ii=1,2              ! omega-loop
        if(ii==1) then
            if(imin==0) then
                i=1
            else
                i=imin
            endif
        endif
        if(ii==2) i=imax
        if ( i/=0 ) then
            omega = 2.d0 * pi * dble(i) / tlen
            call callsuf(omega,nzone,vrmax,vsv,lsuf)
            call calcoef( nzone,omega,qmu,qkappa,coef1,coef2,coef )
            mtmp = isp(spn) + int(spo)
            if ( spo==int(spo) ) mtmp = mtmp - 1
                call calabnum( omega,omegai,rmax,rrho(1,spn),vpv(1,spn),vph(1,spn),&
                              vsv(1,spn),vsh(1,spn),eta(1,spn),ra(mtmp),r0,coef1(spn),coef2(spn),anum(1,1,1),bnum(1,1,1) )
                !c computing the matrix elements independent of l
                isl = 0
                ill = 0
                do j=1,ndc+1
                    if ( iphase(j)==1 ) then
                        isl = isl + 1
                        itmp = isdr+issp(isl)
                        jtmp = jdr+jsp(j)
                        mtmp = kdr+ksp(j)
                        call cala0( nlayer(j),omega,omegai,t(itmp),h1x(itmp), &
                                            h2L(itmp), h2N(itmp),h3ay(itmp),&
                                            h4aL(itmp),h4aN(itmp),h5ay(itmp),&
                                            h6aL(itmp),h6aN(itmp),h7y(itmp),h7z(itmp),&
                                            h8L(itmp), h8N(itmp),coef1(j),coef2(j),cwork(jtmp) )
                        call overlapa( nlayer(j),cwork(jtmp),a0(1,mtmp) )
                        call cala1( nlayer(j),h1x(itmp),&
                                            h2L(itmp),h2N(itmp),h3y(itmp),&
                                            h4L(itmp),h4N(itmp),h5y(itmp),&
                                            h6L(itmp),h6N(itmp),coef1(j),coef2(j),cwork(jtmp) )
                        call overlapa( nlayer(j),cwork(jtmp),a1(1,mtmp) )
                        call cala2(nlayer(j),h1x(itmp),h2L(itmp),h2N(itmp),coef1(j),coef2(j),cwork(jtmp))
                        call overlapa( nlayer(j),cwork(jtmp),a2(1,mtmp) )
                        jtmp = jsdr+jssp(isl)
                        call calhml( nlayer(j),coef1(j),coef2(j),&
                             h3my(-2,jtmp),h5my(-1,jtmp),h4m1L(-1,jtmp),h4m2N(-2,jtmp),&
                             h6m1N(-1,jtmp),h6m2L(-2,jtmp),a1(1,mtmp) )
                    else
                        ill = ill + 1
                        itmp = ildr+ilsp(ill)
                        jtmp = jdr+jsp(j)
                        mtmp = kdr+ksp(j)
                        call calb0( nlayer(j),omega,omegai,p1(itmp),p3(itmp),coef(j),cwork(jtmp))
                        call overlapb( nlayer(j),cwork(jtmp),a0(1,mtmp) )
                        call calb2( nlayer(j),omega,omegai,p2(itmp),cwork(jtmp))
                        call overlapb( nlayer(j),cwork(jtmp),a2(1,mtmp) )
                endif
            enddo

            maxamp = -1.0
            ismall = 0
            ltmp(ii) = maxlmax
            kc = 1
            do l=0,maxlmax   ! l-loop
                ! initialize
                tmpc(1:maxnlay+1) = dcmplx(0.d0)
                if ( ismall>20 ) then
                    if(ltmp(ii)>l) ltmp(ii) = l
                    exit
                endif
                l2 = dble(l)*dble(l+1)
                lsq = dsqrt( l2 )
                !    c computing the coefficient matrix elements
                 !   c --- renewing  mdr
                if (  mod(l,50)==0  ) then
                    !call calmdr( omega,l,nzone,vrmax,vmin,rmax,sufzone )
                    call calspdr( nzone,iphase,nlayer,jjdr,kkdr )
                    nn = kkdr(nzone) + 2 * nlayer(nzone) + 1
                endif
                ! computing the matrix elements
                call cala( ndc,iphase,nlayer,kkdr,kdr,ksp,&
                                    l2,lsq,nn,a0,a1,a2,a )
                ! computing the boundary condition elements
                call calbc( ndc,vrmax,iphase,kkdr,a )

                jtmp = kkdr(spn) + 2 * int(spo)
                mtmp = isp(spn) + int(spo)
                if ( spo==int(spo) ) then
                    jtmp = jtmp - 2
                    mtmp = mtmp - 1
                endif
                call calya( anum(1,1,1),bnum(1,1,1),l2,ra(mtmp),r0,ya,yb,yc,yd )
                do m=-2,2     ! m-loop
                    if ( iabs(m)<=iabs(l) ) then
                ! computing the excitation vector
                        g(1:nn)=0
                        call calg( l,m,coef1(spn),coef2(spn),lsq,&
                                               ecC0,ecF0,ecL0,ya,yb,yc,yd,&
                                               ra(mtmp),r0,mt,g(jtmp) )
                        if ( l==0 ) then
                            !c rearranging the matrix elements for l=0
                            call rea2( nn,a,g,c,d,nzone,iphase,kkdr,spn,kkdr0,nn0 )
                            !c computing the expansion coefficient
                            itmp=1
                            if ( rmin==0.d0 ) itmp=2
                            ns = kkdr0 + ( nint(spo) - 1 )
                            call dcsymbdl( c(1,itmp),1,nn0-itmp+1,1,eps,z(itmp),w(itmp),ll,lli,llj,ier )
                            call dcsbdlv( c(1,itmp),d(itmp),1,nn0-itmp+1,ns-itmp+1,z(itmp))
                        else
                            !c computing the expansion coefficient
                            itmp=1
                            if ( rmin==0.d0 ) itmp=3
                            ns = kkdr(spn) + 2 * ( nint(spo) - 1 )
                            if( mod(l,100)==0) then
                                if ( ( m==-2 ).or.( m==-l ) )&
                                 call dcsymbdl( a(1,itmp),3,nn-itmp+1,6,eps, z(itmp),w(itmp),ll,lli,llj,ier )

                                call dcsbdlv0( a(1,itmp),g(itmp),3,nn-itmp+1,z(itmp))
                                ! sum up c of the same l
                                tmpc(1:nn) = tmpc(1:nn) + g(1:nn)
                            else
                                if ( kc<3 ) kc = 3
                                itmp = kc
                                if ( ( m==-2 ).or.( m==-l ) )&
                                 call dcsymbdl( a(1,itmp),3,nn-itmp+1,6,eps,z(itmp),w(itmp),ll,lli,llj,ier )

                                call dcsbdlv( a(1,itmp),g(itmp),3,nn-itmp+1,ns-itmp+1,z(itmp))
                            endif
                            !c computing ampratio
                            call calamp( g(nn-1),l,lsuf,maxamp,ismall,ratl )

                            if( mod(l,100)==0) call calcutd(nzone,nlayer,tmpc,ratc,nn,iphase,ra,kkdr,kc)

!                                c computing the displacement
                        endif
                    endif
                enddo         ! m-loop
            enddo            ! l-loop
        endif
    enddo                  ! omega-loop
        iimax = dble(max(ltmp(1),ltmp(2))) * tlen / lmaxdivf
    endif                     ! option for shallow events

    call calgrid( nzone,vrmin,vrmax,vpv,vsv,rmin,rmax,iimax,1,tlen, vmin,gridpar,dzpar )
    call calra(inlayer,jnlayer,jnslay,jnllay,&
         dzpar,nzone,vrmin,vrmax,iphase,rmin,nslay,nllay,nlayer,ra,re )
    !c --- checking the parameter
    if ( inlayer>maxnlay ) stop 'The number of grid points is too large.'
    if ( nslay>maxnslay ) stop 'The number of the grid points in the solid is too large.'
    if ( nllay>maxnllay ) stop 'The number of the grid points in the liquid is too large.'
    if ( jnlayer>2*maxnlay ) stop 'The number of the total grid points is too large.'
    if ( ( jnslay>2*maxnslay ).or.( jnllay>2*maxnllay ) ) stop 'The number of the total grid points is too large.'
    !c computing the stack points
    call calsp(ndc,nsl,nll,iphase,nlayer,nllay,&
         isp,jsp,ksp,issp,ilsp,lsp,jssp,isdr,jsdr,ildr,jdr,kdr )
!    c computing the source location
    call calspo(vrmax,iphase,inlayer,r0,rmin,rmax,ra,isp,spo,spn )

    !c ******************* Computing the matrix elements *******************
   !    c computing the structure grid points
    call calstg(nzone,rrho,vpv,vph,vsv,vsh,eta,nlayer,ra,rmax,&
         vnp,vra,rho,kappa,ecKx,ecKy,ecKz,mu,ecL,ecN,r0,spn,ecC0,ecF0,ecL0 )
    !call calinv( vnp,rho,kappa,rhoinv,kappainv )
    rhoinv(1:vnp) = 1.d0 / rho(1:vnp)
    kappainv(1:vnp) = 1.d0 / kappa(1:vnp)
    isl = 0
    ill = 0
    do i=1,ndc+1
        if ( iphase(i)==1 ) then
            isl = isl + 1
            itmp = isdr+issp(isl)
            call calmatc( nlayer(i),vnp,vra,rho,2,0,0,ra(isp(i)), t(itmp) )
            call caltl( nlayer(i),vnp,vra,rho,ra(isp(i)),work(itmp) )
            t(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+t(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecKx,0,0,0,ra(isp(i)),h1x(itmp) )
            call calhl( nlayer(i),vnp,vra,ecKx,ra(isp(i)),work(itmp) )
            h1x(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h1x(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecKy,0,0,0,ra(isp(i)),h1y(itmp) )
            call calhl( nlayer(i),vnp,vra,ecKy,ra(isp(i)),work(itmp) )
            h1y(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h1y(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecKz,0,0,0,ra(isp(i)),h1z(itmp) )
            call calhl( nlayer(i),vnp,vra,ecKz,ra(isp(i)),work(itmp) )
            h1z(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h1z(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecL,0,0,0,ra(isp(i)),h2L(itmp) )
            call calhl( nlayer(i),vnp,vra,ecL,ra(isp(i)),work(itmp) )
            h2L(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h2L(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecN,0,0,0,ra(isp(i)),h2N(itmp) )
            call calhl( nlayer(i),vnp,vra,ecN,ra(isp(i)),work(itmp) )
            h2N(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+h2N(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,ecKx,1,0,1,ra(isp(i)),h5ax(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKy,1,0,1,ra(isp(i)),h5ay(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKz,1,0,1,ra(isp(i)),h5az(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecL,1,0,1,ra(isp(i)),h6aL(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecN,1,0,1,ra(isp(i)),h6aN(itmp) )
            call mtrnp( nlayer(i),h5ax(itmp),h3ax(itmp) )
            call mtrnp( nlayer(i),h5ay(itmp),h3ay(itmp) )
            call mtrnp( nlayer(i),h5az(itmp),h3az(itmp) )
            call mtrnp( nlayer(i),h6aL(itmp),h4aL(itmp) )
            call mtrnp( nlayer(i),h6aN(itmp),h4aN(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKx,2,1,1,ra(isp(i)), h7x(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKy,2,1,1,ra(isp(i)), h7y(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecKz,2,1,1,ra(isp(i)), h7z(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecL,2,1,1,ra(isp(i)), h8L(itmp) )
            call calmatc( nlayer(i),vnp,vra,ecN,2,1,1,ra(isp(i)), h8N(itmp) )
        else
            ill = ill + 1
            itmp = ildr+ilsp(ill)
            call calmatc( nlayer(i),vnp,vra,rhoinv,2,1,1,ra(isp(i)),p1(itmp) )
            call calmatc( nlayer(i),vnp,vra,rhoinv,0,0,0,ra(isp(i)),p2(itmp) )
            call calhl( nlayer(i),vnp,vra,rhoinv,ra(isp(i)),work(itmp) )
            p2(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+p2(itmp:itmp+4*nlayer(i)-1))/2
            call calmatc( nlayer(i),vnp,vra,kappainv,2,0,0,ra(isp(i)),p3(itmp) )
            call caltl( nlayer(i),vnp,vra,kappainv,ra(isp(i)),work(itmp) )
            p3(itmp:itmp+4*nlayer(i)-1)=(work(itmp:itmp+4*nlayer(i)-1)+p3(itmp:itmp+4*nlayer(i)-1))/2
        endif
    enddo
    !c Computing the modified operator of the 1st derivative
    call caltstg( nzone,rrho,vpv,vph,vsv,vsh,eta,nlayer,ra,rmax,vra,kappa,ecKx,ecKy,ecKz,mu,ecL,ecN )
    isl = 0
    do i=1,ndc+1
        if ( iphase(i)==1 ) then
            isl = isl + 1
!           !call submat( nlayer(i),h6aN(itmp),work(itmp),h6N(itmp) )

            itmp = isdr+issp(isl)
            jtmp = isp(i)+i-1
            call calh5( nlayer(i),vra(jtmp),ecKx(jtmp),ra(isp(i)),work(itmp) )
 !           call submat( nlayer(i),h5ax(itmp),work(itmp),h5x(itmp) )
       h5x(itmp:itmp+4*nlayer(i)-1)= h5ax(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
            call calh5( nlayer(i),vra(jtmp),ecKy(jtmp),ra(isp(i)),work(itmp) )
!            call submat( nlayer(i),h5ay(itmp),work(itmp),h5y(itmp) )
       h5y(itmp:itmp+4*nlayer(i)-1)= h5ay(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
            call calh5( nlayer(i),vra(jtmp),ecKz(jtmp),ra(isp(i)),work(itmp) )
!            call submat( nlayer(i),h5az(itmp),work(itmp),h5z(itmp) )
        h5z(itmp:itmp+4*nlayer(i)-1)= h5az(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
            call calh5( nlayer(i),vra(jtmp),ecL(jtmp),ra(isp(i)),work(itmp) )
!            call submat( nlayer(i),h6aL(itmp),work(itmp),h6L(itmp) )
             h6L(itmp:itmp+4*nlayer(i)-1)= h6aL(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)

            call calh5( nlayer(i),vra(jtmp),ecN(jtmp),ra(isp(i)),work(itmp) )
!            call submat( nlayer(i),h6aN(itmp),work(itmp),h6N(itmp) )
            h6N(itmp:itmp+4*nlayer(i)-1)= h6aN(itmp:itmp+4*nlayer(i)-1)-work(itmp:itmp+4*nlayer(i)-1)
           call mtrnp( nlayer(i),h5x(itmp),h3x(itmp) )
            call mtrnp( nlayer(i),h5y(itmp),h3y(itmp) )
            call mtrnp( nlayer(i),h5z(itmp),h3z(itmp) )
            call mtrnp( nlayer(i),h6L(itmp),h4L(itmp) )
            call mtrnp( nlayer(i),h6N(itmp),h4N(itmp) )
            itmp = jsdr+jssp(isl)
            call calhm1( nlayer(i),vra(jtmp),ecKx(jtmp),ra(isp(i)),h5mx(-1,itmp) )
            call calhm1( nlayer(i),vra(jtmp),ecKy(jtmp),ra(isp(i)),h5my(-1,itmp) )
            call calhm1( nlayer(i),vra(jtmp),ecKz(jtmp),ra(isp(i)),h5mz(-1,itmp) )
            call calhm1( nlayer(i),vra(jtmp),ecL(jtmp),ra(isp(i)),h6m1L(-1,itmp) )
            call calhm1( nlayer(i),vra(jtmp),ecN(jtmp),ra(isp(i)),h6m1N(-1,itmp) )
            call calhm2( nlayer(i),vra(jtmp),ecL(jtmp),ra(isp(i)),h6m2L(-2,itmp) )
            call calhm2( nlayer(i),vra(jtmp),ecN(jtmp),ra(isp(i)),h6m2N(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h5mx(-1,itmp),h3mx(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h5my(-1,itmp),h3my(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h5mz(-1,itmp),h3mz(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h6m1L(-1,itmp),h4m2L(-2,itmp) )
            call mtrnp2( nlayer(i),1,2,h6m1N(-1,itmp),h4m2N(-2,itmp) )
            call mtrnp2( nlayer(i),2,1,h6m2L(-2,itmp),h4m1L(-1,itmp) )
            call mtrnp2( nlayer(i),2,1,h6m2N(-2,itmp),h4m1N(-1,itmp) )
        endif
    enddo
!    c ******************** Computing the displacement *********************

    llog = 0
    do i=imin,imax            ! omega-loop
        u(1:3,1:nr)=0
        if ( i/=0 ) then
            omega = 2.d0 * pi * i / tlen
            call callsuf(omega,nzone,vrmax,vsv,lsuf)

            plm(1:3,0:3,1:nr)=0
            call calcoef( nzone,omega,qmu,qkappa,coef1,coef2,coef )
            mtmp = isp(spn) + int(spo)
            if ( spo==int(spo) ) mtmp = mtmp - 1
            call calabnum( omega,omegai,rmax,rrho(1,spn),vpv(1,spn),vph(1,spn),vsv(1,spn),vsh(1,spn),&
             eta(1,spn),ra(mtmp),r0,coef1(spn),coef2(spn),anum(1,1,1),bnum(1,1,1) )
!            c computing the matrix elements independent of l
            isl = 0
            ill = 0
            do j=1,ndc+1
                if ( iphase(j)==1 ) then
                    isl = isl + 1
                    itmp = isdr+issp(isl)
                    jtmp = jdr+jsp(j)
                    mtmp = kdr+ksp(j)
                    call cala0( nlayer(j),omega,omegai,t(itmp),h1x(itmp),&
                     h2L(itmp),h2N(itmp),h3ay(itmp),&
                     h4aL(itmp),h4aN(itmp),h5ay(itmp),&
                     h6aL(itmp),h6aN(itmp),h7y(itmp),h7z(itmp),&
                     h8L(itmp),h8N(itmp),coef1(j),coef2(j),cwork(jtmp) )
                    call overlapa( nlayer(j),cwork(jtmp),a0(1,mtmp))
                    call cala1( nlayer(j),h1x(itmp),&
                     h2L(itmp),h2N(itmp),h3y(itmp),&
                     h4L(itmp),h4N(itmp),h5y(itmp),&
                     h6L(itmp),h6N(itmp),coef1(j),coef2(j),cwork(jtmp) )
                    call overlapa( nlayer(j),cwork(jtmp),a1(1,mtmp) )
                    call cala2( nlayer(j),h1x(itmp),h2L(itmp),h2N(itmp),coef1(j),coef2(j),cwork(jtmp))
                    call overlapa( nlayer(j),cwork(jtmp),a2(1,mtmp) )
                    jtmp = jsdr+jssp(isl)
                    call calhml( nlayer(j),coef1(j),coef2(j),&
                     h3my(-2,jtmp),h5my(-1,jtmp),&
                     h4m1L(-1,jtmp),h4m2N(-2,jtmp),h6m1N(-1,jtmp),h6m2L(-2,jtmp),a1(1,mtmp) )
                else
                    ill = ill + 1
                    itmp = ildr+ilsp(ill)
                    jtmp = jdr+jsp(j)
                    mtmp = kdr+ksp(j)
                    call calb0( nlayer(j),omega,omegai,p1(itmp),p3(itmp),coef(j),cwork(jtmp) )
                    call overlapb( nlayer(j),cwork(jtmp),a0(1,mtmp) )
                    call calb2( nlayer(j),omega,omegai,p2(itmp),cwork(jtmp))
                    call overlapb( nlayer(j),cwork(jtmp),a2(1,mtmp) )
                endif
            enddo
            maxamp = -1
            ismall = 0
            llog = maxlmax
            kc = 1
            do l=0,maxlmax      ! l-loop
                tmpc(1:maxnlay+1) = 0  ! initialize
                if ( ismall>20 ) then
                    if(llog>l) llog = l
                    exit
                endif
                l2 = dble(l*(l+1))
                lsq = dsqrt( l2 )
                !c computing the coefficient matrix elements
                !c --- renewing  mdr
                if (  mod(l,50)==0  ) then
                    call calspdr( nzone,iphase,nlayer,jjdr,kkdr )
                    nn = kkdr(nzone) + 2 * nlayer(nzone) + 1
                endif
                !c ***** Computing the trial function *****
                do ir=1,nr
                    call calbvec( l,theta(ir),phi(ir),plm(1,0,ir),bvec(1,-2,ir) )
                enddo
!              c computing the matrix elements
                call cala( ndc,iphase,nlayer,kkdr,kdr,ksp,l2,lsq,nn,a0,a1,a2,a )
!                c computing the boundary condition elements
                call calbc( ndc,vrmax,iphase,kkdr,a )

                jtmp = kkdr(spn) + 2 * int(spo)
                mtmp = isp(spn) + int(spo)
                if ( spo==int(spo) ) then
                    jtmp = jtmp - 2
                    mtmp = mtmp - 1
                endif
                call calya( anum(1,1,1),bnum(1,1,1),l2,ra(mtmp),r0,ya,yb,yc,yd )
                do m=-2,2        ! m-loop
                    if ( iabs(m)<=iabs(l) ) then
                        !c computing the excitation vector
                        g(1:nn)=0
                        call calg( l,m,coef1(spn),coef2(spn),lsq,ecC0,ecF0,ecL0,ya,yb,yc,yd,ra(mtmp),r0,mt,g(jtmp) )
                        if ( l==0 ) then
!                            c rearranging the matrix elements for l=0
                            call rea2( nn,a,g,c,d,nzone,iphase,kkdr,spn,kkdr0,nn0 )
                            !c computing the expansion coefficient
                            itmp=1
                            if ( rmin==0.d0 ) itmp=2
                            ns = kkdr0 + ( nint(spo) - 1 )
                            call dcsymbdl( c(1,itmp),1,nn0-itmp+1,1,eps,z(itmp),w(itmp),ll,lli,llj,ier )
                            call dcsbdlv( c(1,itmp),d(itmp),1,nn0-itmp+1,ns-itmp+1,z(itmp))
                            !c computing the displacement
                            u(:,1:nr)=d(nn0)*bvec(:,m,1:nr)
                        else
                            !c computing the expansion coefficient
                            itmp=1
                            if ( rmin==0.d0 ) itmp=3
                            ns = kkdr(spn) + 2 * ( nint(spo) - 1 )
                            if( mod(l,100)==0) then
                                if (  m==-2 .or. m==-l ) then
                                    call dcsymbdl( a(1,itmp),3,nn-itmp+1,6,eps,z(itmp),w(itmp),ll,lli,llj,ier )
                                endif
                                call dcsbdlv0( a(1,itmp),g(itmp),3,nn-itmp+1,z(itmp))
                                 ! sum up c of the same l
                                tmpc(1:nn) = tmpc(1:nn) + g(1:nn)
                            else
                                if ( kc<3 ) kc = 3
                                itmp = kc
                                if ( ( m==-2 ).or.( m==-l ) )&
                                 call dcsymbdl( a(1,itmp),3,nn-itmp+1,6,eps,z(itmp),w(itmp),ll,lli,llj,ier )
                                call dcsbdlv( a(1,itmp),g(itmp),3,nn-itmp+1,ns-itmp+1,z(itmp))
                            endif
                            !c computing ampratio
                            call calamp( g(nn-1),l,lsuf,maxamp,ismall,ratl )
                            if( mod(l,100)==0)&
                             call calcutd(nzone,nlayer,tmpc,ratc,nn,iphase,ra,kkdr,kc)

                            !c computing the displacement calu
                            u(1,1:nr) = u(1,1:nr) + g(nn-1) * bvec(1,m,1:nr)
                            u(2:3,1:nr) = u(2:3,1:nr) + g(nn) * bvec(2:3,m,1:nr) / lsq
                        endif
                    endif
                enddo            ! m-loop
            enddo               ! l-loop
        endif
        outputu (1:3,1:nr,i)=u(1:3,1:nr)
    enddo                   ! omega-loop

!c ************************** Files Handling **************************
    if (write_to_file) then
        write(*,*) "kakikomimasu"
        do ir=1,nr
            open(unit=1,file=trim(output(ir)),status='replace',form='unformatted',access='stream',convert='big_endian')
            write(1) tlen,np,1,3,omegai,lat(ir),lon(ir),eqlat,eqlon,r0

            do i= imin,imax
                write(1) i, dble(outputu(1,ir,i)), dimag(outputu(1,ir,i))
                write(1) dble(outputu(2,ir,i)), dimag(outputu(2,ir,i))
                write(1) dble(outputu(3,ir,i)), dimag(outputu(3,ir,i))
            enddo
            close(1)
        enddo
        write(*,*) "Ivalice looks to the horizon"
    endif

    !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    return
 end subroutine tipsv

 program main

   use parameters
   implicit none

   character(len=160) :: parameter_file

   integer np
   integer imin
   integer imax
   integer nzone
   integer nr
   real(dp) :: tlen
   real(dp) :: omegai
   real(dp) :: re
   real(dp) :: ratc
   real(dp) :: ratl
   real(dp) :: vrmin(maxnzone)
   real(dp) :: vrmax(maxnzone)
   real(dp) :: qmu(maxnzone),qkappa(maxnzone)
   real(dp) :: rho(4,maxnzone)
   real(dp) :: vpv(4,maxnzone),vph(4,maxnzone),vsv(4,maxnzone),vsh(4,maxnzone),eta(4,maxnzone)
   real(dp) :: r0
   real(dp) :: mt(3,3)
   real(dp) :: lat(maxnr)
   real(dp) :: lon(maxnr)
   real(dp) :: theta(maxnr)
   real(dp) :: phi(maxnr)
   real(dp) :: eqlat
   real(dp) :: eqlon
   character(len=80) :: output(maxnr)
   complex(dp), allocatable :: outputu(:,:,:)
   logical :: write_to_file = .true.

   ! read input parameters
   call get_command_argument(1, parameter_file)
   print*,parameter_file

   call pinput_tipsv(parameter_file, &
      re,ratc,ratl,tlen,np,omegai,imin,imax, &
      nzone,vrmin,vrmax,rho,vpv,vph,vsv,vsh,eta,qmu,qkappa, &
      r0,eqlat,eqlon,mt,nr,theta,phi,lat,lon,output)

   allocate(outputu(3,nr,imin:imax))

   ! main loop
   write(*,*) 'Enter main loop'

   call tipsv(re,ratc,ratl,tlen,np,omegai,imin,imax, &
      nzone,vrmin,vrmax,rho,vpv,vph,vsv,vsh,eta,qmu,qkappa,&
      r0,eqlat,eqlon,mt,nr,theta,phi,lat,lon,output,write_to_file,&
      outputu)
   write(*,*) 'Done!'
   write(*,*) outputu(3,1,20)

end program main


!##############################################################################
!# ****************************************************************************
!# <name> poisson1d_method0_simple </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module is a demonstration program how to solve a simple 1D Poisson
!# problem with constant coefficients on a simple domain.
!# </purpose>
!##############################################################################

module poisson1d_method0_simple

  use fsystem
  use genoutput
  use storage
  use linearsolver
  use boundary
  use bilinearformevaluation
  use linearformevaluation
  use cubature
  use filtersupport
  use linearsystemscalar
  use linearsystemblock
  use matrixfilters
  use vectorfilters
  use bcassembly
  use triangulation
  use spatialdiscretisation
  use scalarpde
  use ucd
  use element
  use pprocerror
  use genoutput
  use matrixio
  use vectorio
  use meshregion
  use discretebc

  use dg1d_callback

  implicit none

contains

  ! ***************************************************************************

!<subroutine>

  subroutine poisson1d_0_simple

!<description>
  ! This is an all-in-one poisson solver for directly solving a Poisson
  ! problem without making use of special features like collections
  ! and so on. The routine performs the following tasks:
  !
  ! 1.) Create triangulation
  ! 2.) Set up RHS
  ! 3.) Set up matrix
  ! 4.) Create solver structure
  ! 5.) Solve the problem
  ! 6.) Write solution to GMV file
  ! 7.) Release all variables, finish
!</description>

!</subroutine>

    ! Definitions of variables.
    !
    ! We need a couple of variables for this problem. Let us see...
    !
    ! An object for saving the triangulation on the domain
    type(t_triangulation) :: rtriangulation

    ! An object for saving the boundary mesh region
    type(t_meshregion) :: rmeshRegion

    ! An object specifying the discretisation.
    ! This contains also information about trial/test functions,...
    type(t_blockDiscretisation) :: rdiscretisation

    ! A bilinear and linear form describing the analytic problem to solve
    type(t_bilinearForm) :: rform
    type(t_linearForm) :: rlinform

    ! A scalar matrix and vector. The vector accepts the RHS of the problem
    ! in scalar form.
    type(t_matrixScalar) :: rmatrix
    type(t_vectorScalar) :: rrhs

    ! A block matrix and a couple of block vectors. These will be filled
    ! with data for the linear solver.
    type(t_matrixBlock) :: rmatrixBlock
    type(t_vectorBlock) :: rvectorBlock,rrhsBlock,rtempBlock

    ! A set of variables describing the analytic and discrete boundary
    ! conditions.
    type(t_discreteBC), target :: rdiscreteBC

    ! A solver node that accepts parameters for the linear solver
    type(t_linsolNode), pointer :: p_rsolverNode,p_rpreconditioner

    ! An array for the system matrix(matrices) during the initialisation of
    ! the linear solver.
    type(t_matrixBlock), dimension(1) :: Rmatrices

    ! A filter chain that describes how to filter the matrix/vector
    ! before/during the solution process. The filters usually implement
    ! boundary conditions.
    type(t_filterChain), dimension(1), target :: RfilterChain

    ! Error indicator during initialisation of the solver
    integer :: ierror

    ! Error of FE function to reference function
    real(DP) :: derror

    ! Output block for UCD output to GMV file
    type(t_ucdExport) :: rexport
    character(len=SYS_STRLEN) :: sucddir
    real(DP), dimension(:), pointer :: p_Ddata

    ! The number of sub-intervals for the discretisation
    integer :: nintervals = 16

    ! Ok, let us start.
    ! At first, create the basic triangulation.
    ! Our domain is [0, 1], divided into nintervals sub-intervals.
    call tria_createRawTria1D(rtriangulation, 0.0_DP, 1.0_DP, nintervals)

    ! As the tria_createRawTria1D routine always generates a grid
    ! with sub-intervals of equal length, we can optionally disturb
    ! the mesh.
    !CALL meshmod_disturbMesh(rtriangulation, 0.2_DP)

    ! And create information about adjacencies and everything one needs from
    ! a triangulation.
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! Now we can start to initialise the discretisation. At first, set up
    ! a block discretisation structure that specifies the blocks in the
    ! solution vector. In this simple problem, we only have one block.
    call spdiscr_initBlockDiscr (rdiscretisation, 1, rtriangulation)

    ! In the next step, we will define the element type and the cubature
    ! formula that is to be used. For this 1D poisson-example we currently
    ! have 2 possible element types: linear and quadratic ones.
    ! For linear elements the trapezoidal formula satisfies all our
    ! needs, for quadratic elements we should choose a 3-point Gauss-formula.
    !
    ! rdiscretisation%Rdiscretisations is a list of scalar discretisation
    ! structures for every component of the solution vector.
    ! Initialise the first element of the list to specify the element
    ! and cubature rule for this solution component:
    call spdiscr_initDiscr_simple (rdiscretisation%RspatialDiscr(1), &
    ! Setting up a linear element and trapezoidal rule would be...
                                   EL_P1_1D,CUB_TRZ_1D,rtriangulation)
    ! Setting up a quadratic element and 3-point Gauss rule would be...
                                   !EL_P2_1D,CUB_G3_1D,rtriangulation)
    ! Setting up a cubic spline element and 4-point Gauss rule would be...
                                   !EL_S31_1D,CUB_G4_1D,rtriangulation)

    ! Now as the discretisation is set up, we can start to generate
    ! the structure of the system matrix which is to solve.
    ! We create a scalar matrix, based on the discretisation structure
    ! for our one and only solution component.
    call bilf_createMatrixStructure (rdiscretisation%RspatialDiscr(1),&
                                     LSYSSC_MATRIX9,rmatrix)

    ! And now to the entries of the matrix. For assembling of the entries,
    ! we need a bilinear form, which first has to be set up manually.
    ! We specify the bilinear form (grad Psi_j, grad Phi_i) for the
    ! scalar system matrix in 1D.
    rform%itermCount = 1
    rform%Idescriptors(1,1) = DER_DERIV_X
    rform%Idescriptors(2,1) = DER_DERIV_X

    ! In the standard case, we have constant coefficients:
    rform%ballCoeffConstant = .true.
    rform%BconstantCoeff = .true.
    rform%Dcoefficients(1)  = 1.0
    rform%Dcoefficients(2)  = 1.0

    ! Now we can build the matrix entries.
    ! We specify the callback function coeff_Laplace for the coefficients.
    ! As long as we use constant coefficients, this routine is not used.
    ! By specifying ballCoeffConstant = BconstantCoeff = .FALSE. above,
    ! the framework will call the callback routine to get analytical
    ! data.
    call bilf_buildMatrixScalar (rform,.true.,rmatrix,coeff_Laplace_1D)

    ! The same has to be done for the right hand side of the problem.
    ! At first set up the corresponding linear form (f,Phi_j):
    rlinform%itermCount = 1
    rlinform%Idescriptors(1) = DER_FUNC

    ! ... and then discretise the RHS to get a discrete version of it.
    ! Again we simply create a scalar vector based on the one and only
    ! discretisation structure.
    ! This scalar vector will later be used as the one and only first
    ! component in a block vector.
    call linf_buildVectorScalar (rdiscretisation%RspatialDiscr(1),&
                                 rlinform,.true.,rrhs,coeff_RHS_1D)

    ! The linear solver only works for block matrices/vectors - but above,
    ! we created scalar ones. So the next step is to make a 1x1 block
    ! system from the matrices/vectors above which the linear solver
    ! understands.
    call lsysbl_createMatFromScalar (rmatrix,rmatrixBlock,rdiscretisation)
    call lsysbl_createVecFromScalar (rrhs,rrhsBlock,rdiscretisation)

    ! Now we have the raw problem. What is missing is the definition of the boundary
    ! conditions.
    ! For implementing boundary conditions, we use a `filter technique with
    ! discretised boundary conditions`. This means, we first have to calculate
    ! a discrete version of the analytic BC, which we can implement into the
    ! solution/RHS vectors using the corresponding filter.
    !
    ! In contrast to the 2D poisson examples, we will directly set the
    ! dirichlet boundary conditions by hand instead of discretising an analytic
    ! boundary condition function using a boundary structure.
    !
    ! Initialise the structure that collects the discrete BC`s:
    call bcasm_initDiscreteBC(rdiscreteBC)

    ! In 1D we have 2 possibilities to describe Dirichlet BCs on the interval
    ! ends. One possibility is to use the bcasm_initDirichletBC_1D routine.
    ! The following call would prescribe 0 on both interval ends:
    !
    ! CALL bcasm_newDirichletBC_1D(rdiscretisation, rdiscreteBC, 0.0_DP, 0.0_DP)
    !
    ! The second possibility is using mesh regions:
    !
    ! Create a mesh region describing the mesh`s boundary based on the
    ! nodal-property-array of the current triangulation.
    call mshreg_createFromNodalProp(rmeshRegion, rtriangulation, &
                                      MSHREG_IDX_ALL)

    ! Describe Dirichlet BCs on that mesh region
    call bcasm_newDirichletBConMR(rdiscretisation, 1, rdiscreteBC, rmeshRegion,&
                                  getBoundaryValuesMR_1D)

    ! Free the mesh region structure as we will not need it anymore
    call mshreg_done(rmeshRegion)

    ! Hang the pointer into the vector and matrix. That way, these
    ! boundary conditions are always connected to that matrix and that
    ! vector.
    rmatrixBlock%p_rdiscreteBC => rdiscreteBC
    rrhsBlock%p_rdiscreteBC => rdiscreteBC

    ! Now we have block vectors for the RHS and the matrix. What we
    ! need additionally is a block vector for the solution and
    ! temporary data. Create them using the RHS as template.
    ! Fill the solution vector with 0:
    call lsysbl_createVecBlockIndirect (rrhsBlock, rvectorBlock, .true.)
    call lsysbl_createVecBlockIndirect (rrhsBlock, rtempBlock, .false.)

    ! Next step is to implement boundary conditions into the RHS,
    ! solution and matrix. This is done using a vector/matrix filter
    ! for discrete boundary conditions.
    ! The discrete boundary conditions are already attached to the
    ! vectors/matrix. Call the appropriate vector/matrix filter that
    ! modifies the vectors/matrix according to the boundary conditions.
    call vecfil_discreteBCrhs (rrhsBlock)
    call vecfil_discreteBCsol (rvectorBlock)
    call matfil_discreteBC (rmatrixBlock)

    ! During the linear solver, the boundary conditions are also
    ! frequently imposed to the vectors. But as the linear solver
    ! does not work with the actual solution vectors but with
    ! defect vectors instead.
    ! So, set up a filter chain that filters the defect vector
    ! during the solution process to implement discrete boundary conditions.
    RfilterChain(1)%ifilterType = FILTER_DISCBCDEFREAL

    ! Attach the above filter chain to the solver, so that the solver
    ! automatically filters the vector during the solution process!
    !
    ! We now have the option to create a preconditioner for the solver.
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Preconditioner Remark:
    ! ----------------------
    ! Please keep in mind that if the 1D grid for the discretisation was
    ! created using the tria_createRawTria1D routine (which is the default
    ! case in this example) and the grid was NOT refined afterwards (which is
    ! also the default case in this example), the resulting matrix will be
    ! tri-diagonal for linear elements.
    ! In this case, a LU-decomposition would produce no fill-in - therefore the
    ! ILU(0) preconditioner computes a complete LU-decomposition of the system
    ! matrix. So do not wonder if you set ILU(0) as a preconditioner and the
    ! solver always converges after 1 iteration... ^_^
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    nullify(p_rpreconditioner)
    ! Setting up a Jacobi-Preconditioner would be..
    !CALL linsol_initJacobi (p_rpreconditioner)
    ! Setting up a Jin-Wei-Tam-Preconditioner would be...
    !CALL linsol_initJinWeiTam (p_rpreconditioner)
    ! Setting up a SOR[1.2]-Preconditioner would be...
    !CALL linsol_initSOR (p_rpreconditioner, 1.2_DP)
    ! Setting up a SSOR[1.2]-Preconditioner would be...
    !CALL linsol_initSSOR (p_rpreconditioner, 1.2_DP)
    ! Setting up a ILU(0)-Preconditioner would be...
    !CALL linsol_initMILUs1x1(p_rpreconditioner, 0, 0.0_DP)

    ! We now need to create a solver for the linear system.
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Solver Remark:
    ! --------------
    ! Please keep in mind that the CG solver needs a symmetric preconditioner
    ! and will (most probably) not work with unsymmetric preconditioners as
    ! SOR or (M)ILU(s).
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Setting up a Defect-Correction-Solver would be...
    !CALL linsol_initDefCorr (p_rsolverNode,p_rpreconditioner,RfilterChain)
    ! Setting up a PCG-Solver would be...
    !CALL linsol_initCG (p_rsolverNode,p_rpreconditioner,RfilterChain)
    ! Setting up a BiCGStab-Solver would be...
    call linsol_initBiCGStab (p_rsolverNode,p_rpreconditioner,RfilterChain)
    ! Setting up a GMRES(17)-Solver would be...
    !CALL linsol_initGMRES (p_rsolverNode,17,p_rpreconditioner,RfilterChain)

    ! Set the output level of the solver to 2 for some output
    p_rsolverNode%ioutputLevel = 2

    ! Attach the system matrix to the solver.
    ! First create an array with the matrix data (on all levels, but we
    ! only have one level here), then call the initialisation
    ! routine to attach all these matrices.
    ! Remark: Do not make a call like
    !    CALL linsol_setMatrices(p_RsolverNode,(/p_rmatrix/))
    ! This does not work on all compilers, since the compiler would have
    ! to create a temp array on the stack - which does not always work!
    Rmatrices = (/rmatrixBlock/)
    call linsol_setMatrices(p_RsolverNode,Rmatrices)

    ! Initialise structure/data of the solver. This allows the
    ! solver to allocate memory / perform some precalculation
    ! to the problem.
    call linsol_initStructure (p_rsolverNode, ierror)
    if (ierror .ne. LINSOL_ERR_NOERROR) stop
    call linsol_initData (p_rsolverNode, ierror)
    if (ierror .ne. LINSOL_ERR_NOERROR) stop

    ! Finally solve the system. As we want to solve Ax=b with
    ! b being the real RHS and x being the real solution vector,
    ! we use linsol_solveAdaptively. If b is a defect
    ! RHS and x a defect update to be added to a solution vector,
    ! we would have to use linsol_precondDefect instead.
    call linsol_solveAdaptively (p_rsolverNode,rvectorBlock,rrhsBlock,rtempBlock)

    ! That is it, rvectorBlock now contains our solution. We can now
    ! start the postprocessing.
    !
    ! Get the path for writing postprocessing files from the environment variable
    ! $UCDDIR. If that does not exist, write to the directory "./gmv".
    if (.not. sys_getenv_string("UCDDIR", sucddir)) sucddir = './gmv'

    ! Start UCD export to GMV file:
    call ucd_startGMV (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       trim(sucddir)//'/u1d_0_simple.gmv')

    call lsyssc_getbase_double (rvectorBlock%RvectorBlock(1),p_Ddata)
    call ucd_addVariableVertexBased (rexport,'sol',UCD_VAR_STANDARD, p_Ddata)

    ! Write the file to disc, that is it.
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! Calculate the error to the reference function.
    call pperr_scalar (rvectorBlock%RvectorBlock(1),PPERR_L2ERROR,derror,&
                       getReferenceFunction_1D)
    call output_line ('L2-error: ' // sys_sdEL(derror,10) )
    call pperr_scalar (rvectorBlock%RvectorBlock(1),PPERR_H1ERROR,derror,&
                       getReferenceFunction_1D)
    call output_line ('H1-error: ' // sys_sdEL(derror,10) )

    ! We are finished - but not completely!
    ! Now, clean up so that all the memory is available again.
    !
    ! Release solver data and structure
    call linsol_doneData (p_rsolverNode)
    call linsol_doneStructure (p_rsolverNode)

    ! Release the solver node and all subnodes attached to it (if at all):
    call linsol_releaseSolver (p_rsolverNode)

    ! Release the block matrix/vectors
    call lsysbl_releaseVector (rtempBlock)
    call lsysbl_releaseVector (rvectorBlock)
    call lsysbl_releaseVector (rrhsBlock)
    call lsysbl_releaseMatrix (rmatrixBlock)

    ! Release the scalar matrix/rhs vector which were used to create
    ! the block matrices/vectors. These must exist as long as the
    ! block matrices/vectors exist, as the block matrices/vectors are
    ! only 'copies' of the scalar ones, sharing the same handles!
    call lsyssc_releaseVector (rrhs)
    call lsyssc_releaseMatrix (rmatrix)

    ! Release our discrete version of the boundary conditions
    call bcasm_releaseDiscreteBC (rdiscreteBC)

    ! Release the discretisation structure and all spatial discretisation
    ! structures in it.
    call spdiscr_releaseBlockDiscr(rdiscretisation)

    ! Release the triangulation.
    call tria_done (rtriangulation)

  end subroutine

end module


c=======================================================================
c=======================================================================
c     SUBROUTINES FOR BDP Models
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c=======================================================================
c=======================================================================

c=======================================================================
c=======================================================================
c=======================================================================
c     AUXILIARY FUNCTIONS/COMMON FUNCTIONS
c=======================================================================
c=======================================================================
c=======================================================================

c=======================================================================
      integer function ifloor(x)
c=======================================================================
      implicit none
      real*8 x
      ifloor=x
      if(ifloor.gt.x) ifloor=ifloor-1
      end

c=======================================================================
      subroutine nrmu(nsteps,nsubject,betar,b,z,sigma2,kk,mu0,s0,
     &                mu,meancg,varcg)
c=======================================================================
c     Newton-Raphson for the full conditional of the mean in an
c     extended BDP prior.
c
c     Alejandro Jara, 2007
c=======================================================================
      implicit none
      integer i,j,l
      integer nsteps,nsubject,kk
      real*8 betar,b(nsubject),z(nsubject),sigma2,mu,mu0,s0
      real*8 meancg,varcg,tmp1,tt1,tt2,q1,q2,q3,q4,q5,q6
      real*8 first,second
      real*8 cdfnorm,dnrm

      tmp1=mu

      do i=1,nsteps

         q1=0.d0
         q2=0.d0
         q3=0.d0
         q4=0.d0
         q5=0.d0
         q6=0.d0

         do j=1,nsubject
            call jcomponentbd(z(j),kk,l)

            tt1=dnrm((b(j)-tmp1)/sqrt(sigma2),0.d0,1.d0,0)
            tt2=cdfnorm(b(j),tmp1,sqrt(sigma2),1,0)
            q1=q1+dble(l-1)*tt1/tt2
            q2=q2+dble(kk-l)*tt1/(1.d0-tt2)

            q3=q3-((b(j)-tmp1)/sqrt(sigma2))*dble(l-1)*tt1/tt2
            q4=q4+dble(l-1)*(tt1*tt1)/(tt2*tt2)
            q5=q5-((b(j)-tmp1)/sqrt(sigma2))*dble(kk-l)*tt1/(1.d0-tt2)
            q6=q6+dble(kk-l)*(tt1*tt1)/((1.d0-tt2)*(1.d0-tt2))
         end do

         first=betar-dble(nsubject)*tmp1-q1+q2
         first=first/sigma2
         first=first-(tmp1/s0)+(mu0/s0)

         second= -(dble(nsubject)/sigma2) +
     &            (1.d0/(sigma2*sqrt(sigma2)))*q3 -
     &            (1.d0/(sigma2*sqrt(sigma2)))*q4 -
     &            (1.d0/(sigma2*sqrt(sigma2)))*q5 -
     &            (1.d0/(sigma2*sqrt(sigma2)))*q6 -
     &            (1.d0/s0)

         tmp1=tmp1-first/second
      end do

      q3=0.d0
      q4=0.d0
      q5=0.d0
      q6=0.d0

      do j=1,nsubject
         call jcomponentbd(z(j),kk,l)

         tt1=dnrm((b(j)-tmp1)/sqrt(sigma2),0.d0,1.d0,0)
         tt2=cdfnorm(b(j),tmp1,sqrt(sigma2),1,0)

         q3=q3-((b(j)-tmp1)/sqrt(sigma2))*dble(l-1)*tt1/tt2
         q4=q4+dble(l-1)*(tt1*tt1)/(tt2*tt2)
         q5=q5-((b(j)-tmp1)/sqrt(sigma2))*dble(kk-l)*tt1/(1.d0-tt2)
         q6=q6+dble(kk-l)*(tt1*tt1)/((1.d0-tt2)*(1.d0-tt2))
      end do

      second= -(dble(nsubject)/sigma2) +
     &         (1.d0/(sigma2*sqrt(sigma2)))*q3 -
     &         (1.d0/(sigma2*sqrt(sigma2)))*q4 -
     &         (1.d0/(sigma2*sqrt(sigma2)))*q5 -
     &         (1.d0/(sigma2*sqrt(sigma2)))*q6 -
     &         (1.d0/s0)

      meancg=tmp1
      varcg=-1.d0/second

      if(varcg.lt.0.d0)then
        call rexit("Error Newton-Raphson approximation for mu")
      end if

      return
      end

c=======================================================================
       subroutine jcomponentbd(y,k,j)
c=======================================================================
c      return the component j in {1,...,k} corresponding to the y
c      in [0,1] random variable in a Bernstein-Dirichlet prior.
c
c      Alejandro Jara, 2007
c=======================================================================
       implicit none
       integer iceil,k,j
       real*8 y
c       j=int(y*dble(k))+1

       j=iceil(y*k)

c       if(y.gt.dble(j)/dble(k))then
c          call dblepr("y",-1,y,1)
c          call intpr("k",-1,k,1)
c          call intpr("j",-1,j,1)
c          call rexit("Error in 'jcomponent'")
c       end if

c       if(y.lt.dble(j-1)/dble(k))then
c          call dblepr("y",-1,y,1)
c          call intpr("k",-1,k,1)
c          call intpr("j",-1,j,1)
c          call rexit("Error in 'jcomponent'")
c       end if

       return
       end

c=======================================================================
       subroutine baseevalbd(x,k,a0,b0,eval)
c=======================================================================
c      evaluates the Bernstein polinomial at the
c      baseline distribution, Beta(a0,b0), in a Bernstein-Dirichlet
c      prior.
c
c      Alejandro Jara, 2007
c=======================================================================
       implicit none
       integer i,k
       real*8 a0,b0,cdfbetas,dbet,x,eval

       eval=0.d0
       do i=1,k
          eval=eval+
     &        (cdfbetas(dble(i)/dble(k),a0,b0,1,0)-
     &         cdfbetas(dble(i-1)/dble(k),a0,b0,1,0))*
     &         dbet(x,dble(i),dble(k-i+1),0)
       end do
       return
       end

c=======================================================================
       subroutine clustevalbd(x,k,y,eval)
c=======================================================================
c      evaluates the cluster contribution for the cluster
c      defined by y in a Bernstein-Dirichlet prior.
c
c      Alejandro Jara, 2007
c=======================================================================
       implicit none
       integer j,k
       real*8 dbet,x,y,eval

       call jcomponentbd(y,k,j)
       eval=dbet(x,dble(j),dble(k-j+1),0)

       return
       end

c=======================================================================
       subroutine samplekbd(nrec,x,y,prob,kmax,k)
c=======================================================================
c      generate k from its conditional distribution in a
c      Bernstein-Dirichlet prior. This function assumes that the prior
c      for k is a uniform U(1,kmax).
c
c      Alejandro Jara, 2007.
c=======================================================================
       implicit none
       integer i,j,kmax,k,nrec
       real*8 eval,prob(kmax),y(nrec),x(nrec),tmp1

       do i=1,kmax
          tmp1=0.d0
          do j=1,nrec
             call clustevalbd(x(j),i,y(j),eval)
             tmp1=tmp1+log(eval)
          end do
          prob(i)=exp(tmp1)*(1.d0/dble(kmax))
       end do

       call simdisc(prob,kmax,kmax,k)

       return
       end

c=======================================================================
       subroutine sampleybd(x,kmax,prob,a0,b0,k,y)
c=======================================================================
c      generate y from the baseline in a
c      Bernstein-Dirichlet prior.
c
c      Alejandro Jara, 2007.
c=======================================================================
       implicit none
       integer i,j,kmax,k,status
       real*8 a0,b0,bound,dbet,prob(kmax),tmp1,tmp2,tmp3,x
       real*8 y,y2
       real*8 tt1,tt2,tt3,tt4
       real*8 cdfbetas
       real runif

       do i=1,k
          tmp1=
     &        (cdfbetas(dble(i)/dble(k),a0,b0,1,0)-
     &         cdfbetas(dble(i-1)/dble(k),a0,b0,1,0))*
     &         dbet(x,dble(i),dble(k-i+1),0)
          prob(i)=tmp1
       end do

       call simdisc(prob,kmax,k,j)

       if(a0.eq.1.d0.and.b0.eq.1.d0)then
          y=(dble(j-1)+dble(runif()))/dble(k)
        else
          tt3=dble(j-1)/dble(k)
          tt4=1.d0-dble(j-1)/dble(k)
          call cdfbet(1,tt1,tt2,tt3,tt4,a0,b0,status,bound)
          if(status.ne.0)then
             call rexit("Error in 'sampleybd'")
          end if
          tmp1=tt1

          tt3=dble(j)/dble(k)
          tt4=1.d0-dble(j)/dble(k)
          call cdfbet(1,tt1,tt2,tt3,tt4,a0,b0,status,bound)
          if(status.ne.0)then
             call rexit("Error in 'sampleybd'")
          end if
          tmp2=tt1

          tmp3=tmp1+dble(runif())*(tmp2-tmp1)

          call cdfbet(2,tmp3,1.d0-tmp3,y,y2,a0,b0,status,bound)
          if(status.ne.0)then
             call rexit("Error in 'sampleybd'")
          end if

       end if

       if(y.gt.dble(j)/dble(k))then
          call rexit("Error in 'sampleybd'")
       end if

       if(y.le.dble(j-1)/dble(k))then
          call rexit("Error in 'sampleybd'")
       end if

       if(y.eq.0.d0)then
          call rexit("Error in 'sampleybd' (0)")
       end if

       return
       end

c=======================================================================
      subroutine logpsigma(nsubject,kk,b,z,mu,sigma,loglikn)
c=======================================================================
c     Compute the full conditional of sigma in an extended BDP prior
c     when a uniform prior on sigma is used.
c
c     Alejandro Jara, 2007
c=======================================================================
      implicit none
      integer i
      integer nsubject,kk,l
      real*8 b(nsubject),z(nsubject),mu,sigma,loglikn
      real*8 dnrm,cdfnorm

      loglikn=0.d0
      do i=1,nsubject
         call jcomponentbd(z(i),kk,l)
         loglikn=loglikn+dble(l-1)*cdfnorm(b(i),mu,sigma,1,1)
         loglikn=loglikn+dble(kk-l)*cdfnorm(b(i),mu,sigma,0,1)
         loglikn=loglikn+dnrm(b(i),mu,sigma,1)
      end do

      return
      end

c=======================================================================
      subroutine logpsigma2(nsubject,kk,b,z,mu,sigma2,tau1,tau2,
     &                      loglikn)
c=======================================================================
c     Compute the full conditional of sigma2 in an extended BDP prior
c     in the case an inverse gamma prior on sigma2 is used.
c
c     Alejandro Jara, 2007
c=======================================================================
      implicit none
      integer i
      integer nsubject,kk,l
      real*8 b(nsubject),z(nsubject),mu,sigma2,loglikn
      real*8 dnrm,cdfnorm,sigma,tau1,tau2

      sigma=sqrt(sigma2)
      loglikn=0.d0
      do i=1,nsubject
         call jcomponentbd(z(i),kk,l)
         loglikn=loglikn+dble(l-1)*cdfnorm(b(i),mu,sigma,1,1)
         loglikn=loglikn+dble(kk-l)*cdfnorm(b(i),mu,sigma,0,1)
         loglikn=loglikn+dnrm(b(i),mu,sigma,1)
      end do

      loglikn=loglikn-(0.5d0*tau1+1.d0)*log(sigma2)-0.5d0*tau2/sigma2

      return
      end


      subroutine surq_greenampt

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    Predicts daily runoff given breakpoint precipitation and snow melt
!!    using the Green & Ampt technique

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    idt         |minutes       |length of time step used to report
!!                               |precipitation data for sub-daily modeling
!!    ihru        |none          |HRU number
!!    iyr         |year          |year being simulated (eg 1980)
!!    nstep       |none          |max number of time steps per day
!!    newrti(:)   |mm/hr         |infiltration rate for last time step from the
!!                               |previous day
!!    nstep       |none          |number of rainfall time steps for day
!!    precipdt(:) |mm H2O        |precipitation for the time step during day
!!    sol_k(1,:)  |mm/hr         |saturated hydraulic conductivity of 1st soil
!!                               |layer
!!    sol_por(:,:)|none          |total porosity of soil layer expressed as a
!!                               |fraction of the total volume
!!    sol_sumfc(:)|mm H2O        |amount of water held in the soil profile
!!                               |at field capacity
!!    sol_sw(:)   |mm H2O        |amount of water stored in soil profile on
!!                               |any given day
!!    swtrg(:)    |none          |rainfall event flag:
!!                               |  0: no rainfall event over midnight
!!                               |  1: rainfall event over midnight
!!    wfsh(:)     |mm            |average capillary suction at wetting front
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hhqday(:)   |mm H2O        |surface runoff generated each hour of day
!!                               |in HRU
!!    newrti(:)   |mm/hr         |infiltration rate for last time step from the
!!                               |previous day
!!    surfq(:)    |mm H2O        |surface runoff for the day in HRU
!!    swtrg(:)    |none          |rainfall event flag:
!!                               |  0: no rainfall event over midnight
!!                               |  1: rainfall event over midnight
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    adj_hc      |mm/hr         |adjusted hydraulic conductivity
!!    cuminf(:)   |mm H2O        |cumulative infiltration for day
!!    cumr(:)     |mm H2O        |cumulative rainfall for day
!!    dthet       |mm/mm         |initial moisture deficit
!!    excum(:)    |mm H2O        |cumulative runoff for day
!!    exinc(:)    |mm H2O        |runoff for time step
!!    f1          |mm H2O        |test value for cumulative infiltration
!!    j           |none          |HRU number
!!    k           |none          |counter
!!    kk          |hour          |hour of day in which runoff is generated
!!    psidt       |mm            |suction at wetting front*initial moisture
!!                               |deficit
!!    rateinf(:)  |mm/hr         |infiltration rate for time step
!!    rintns(:)   |mm/hr         |rainfall intensity
!!    soilw       |mm H2O        |amount of water in soil profile
!!    tst         |mm H2O        |test value for cumulative infiltration
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sum, Exp, Real, Mod

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j, k, kk,sb
      real :: adj_hc, dthet, soilw, psidt, tst, f1
      real, dimension (nstep+1) :: cumr, cuminf, excum, exinc, rateinf
      real, dimension (nstep+1) :: rintns
        !! array location #1 is for last time step of prev day

       j = 0
       j = ihru
       sb = hru_sub(j)

       !! reset values for day
       cumr = 0.
       cuminf = 0.
       excum = 0.
       exinc = 0.
       rateinf = 0.
       rintns = 0.

       !! calculate effective hydraulic conductivity
       adj_hc = 0.
       adj_hc = (56.82 * sol_k(1,j) ** 0.286)
     &               / (1. + 0.051 * Exp(0.062 * cnday(j))) - 2.
       if (adj_hc <= 0.) adj_hc = 0.001

       dthet = 0.
       if (swtrg(j) == 1) then
         swtrg(j) = 0
         dthet = 0.001 * sol_por(1,j) * 0.95
         rateinf(1) = newrti(j)
         newrti(j) = 0.
       else
         soilw = 0.
         if (sol_sw(j) >= sol_sumfc(j)) then
           soilw = 0.999 * sol_sumfc(j)
         else
           soilw = sol_sw(j)
         end if
         dthet = (1. - soilw / sol_sumfc(j)) * sol_por(1,j) * 0.95
         rateinf(1) = 2000.
       end if

       psidt = 0.
       psidt = dthet * wfsh(j)

       k = 1
       rintns(1) = 60. * precipdt(2) / Real(idt)  !! urban 60./idt  NK Feb 4,08

       do k = 2, nstep+1
         !! calculate total amount of rainfall during day for time step
         cumr(k) = cumr(k-1) + precipdt(k)
         !! and rainfall intensity for time step
         rintns(k) = 60. * precipdt(k+1) / Real(idt) !!urban 60./idt NK Feb 4,08

         !! if rainfall intensity is less than infiltration rate
         !! everything will infiltrate
         if (rateinf(k-1) >= rintns(k-1)) then
           cuminf(k) = cuminf(k-1) + rintns(k-1) * Real(idt) / 60. !!urban 60./idt NK Feb 4,08
           if (excum(k-1) > 0.) then
             excum(k) = excum(k-1)
             exinc(k) = 0.
           else
             excum(k) = 0.
             exinc(k) = 0.
           end if
          else
          !! if rainfall intensity is greater than infiltration rate
          !! find cumulative infiltration for time step by successive
          !! substitution
           tst = 0.
           tst = adj_hc * Real(idt) / 60.  !!urban 60./idt NK Feb 4,08
           do
             f1 = 0.
             f1 = cuminf(k-1) + adj_hc * Real(idt) / 60. +
     &             psidt * Log((tst + psidt)/(cuminf(k-1) + psidt))
             if (Abs(f1 - tst) <= 0.001) then
               cuminf(k) = f1
               excum(k) = cumr(k) - cuminf(k)
               exinc(k) = excum(k) - excum(k-1)
               if (exinc(k) < 0.) exinc(k) = 0.
               hhqday(k-1) = exinc(k)
               exit
             else
               tst = 0.
               tst = f1
             end if
           end do
         end if

	   !! Urban Impervious cover
	   if (iurban(j)>0) then
	      !runoff from pervious area
	      hhqday(k-1) = hhqday(k-1) * (1.- fcimp(urblu(j)))

           !runoff from impervious area with initial abstraction
            ubnrunoff(k-1) = (precipdt(k) - abstinit) *
     &                       fcimp(urblu(j))
            if ( ubnrunoff(k-1)<0)  ubnrunoff(k-1) = 0.
         end if

	   !! daily total runoff
	   surfq(j) = surfq(j) + hhqday(k-1) + ubnrunoff(k-1)

         !! calculate new rate of infiltration
         rateinf(k) = adj_hc * (psidt / (cuminf(k) + 1.e-6) + 1.)

      end do

      if (Sum(precipdt) > 12.) then
        swtrg(j) = 1
        newrti(j) = rateinf(nstep)
      end if

      return
 5000 format(//,'Excess rainfall calculation for day ',i3,' of year ',
     &        i4,' for sub-basin',i4,'.',/)
 5001 format(t2,'Time',t9,'Incremental',t22,'Cumulative',t35,'Rainfall',
     &       t45,'Infiltration',t59,'Cumulative',t71,'Cumulative',t82,
     &       'Incremental',/,t2,'Step',t10,'Rainfall',t23,'Rainfall',
     &       t35,'Intensity',t49,'Rate',t58,'Infiltration',t73,'Runoff',
     &       t84,'Runoff',/,t12,'(mm)',t25,'(mm)',t36,'(mm/h)',t48,
     &       '(mm/h)',t62,'(mm)',t74,'(mm)',t85,'(mm)',/)
 5002 format(i5,t12,f5.2,t24,f6.2,t36,f6.2,t47,f7.2,t61,f6.2,t73,f6.2,
     &       t84,f6.2)
      end